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Foreword 



This programmer's guide contains information and instructions 
for implementing your application programs with Access Manager™ . 
It is specifically directed at implementations using the CP/M® 
family of operating systems. 

The Access Manager Programmer's Guide was designed and written 
as the companion manual to the Access Manager Reference Manual. 
Please note that there are two separate versions of the programmer's 
guide, an 8080 and an 8086 version. 

Section 1 of this manual describes the general guidelines and 
restrictions you must observe when using Access Manager with a 
particular operation system. Sections 2, 3, and 4 provide detailed 
instructions for using and implementing Access Manager with programs 
written in CBASIC® Compiler (CB80™ ), PL/I-80™ , and Pascal/MT+™ . 



Table of Contents 

1 Implementation Guidelines 

1.1 Main Access Manager Components 1-1 

1.2 Memory Requirements for Access Manager Code .... 1-3 

1.3 Access Manager Design Constraints 1-4 

1.4 Multiuser Module under MP/M II 1-5 

1.4.1 Creating Access Manager Queues . 1-5 

1.4.2 Invoking Shared Routines 1-6 

1.4.3 Cancelling Shared Routines 1-7 

1.4.4 Creating Custom Background Servers 1-7 

1.4.5 Data and Index Files 1-8 

1.5 Configuring the Single-user Buffer Area 1-8 

2 Using Access Manager with CB80 Applications 

2.1 Linking Access Manager to Your Application Program 2-1 

2.1.1 Linking Single-user CB80 Applications . . . 2-1 

2.1.2 Linking Multiuser CB80 Applications .... 2-1 

2.2 External Declaration of Access Manager Routines . . 2-2 

2.3 Coding Numeric Key Values 2-2 

2.4 Using the RECREATE. BAS Utility Program 2-2 

2.5 CB80 Data File Example Listing 2-4 

2.6 CB80 DATABASE Source Code 2-7 

2.7 CB80 Source Code Data File Routines 2-24 

2.7.1 OPEN. DATA. FILE% (DATA. FILE$, FILE. N0%, RECORD 2-24 

2.7.2 CLOSE. DATA. FILE% (FILE. N0%) 2-24 

2.7.3 NEW. DATA% (FILE. N0%) 2-24 

2.7.4 RETURN. DATA% (FILE. N0%, DATA. RECORD %, MESSAGES $) 2-25 

2.7.5 DATA. FILE. SIZE% (FILE. N0%) 2-26 

2.7.6 DATA. FILE. UTILIZATION% (FILE. N0%) 2-26 

3 Using Access Manager with PL/I-80 Applications 

3.1 Linking Access Manager to Your Application Program 3-1 



Table of Contents 
(continued) 

3.1.1 Linking Single-user PL/I-80 Applications . . 3-1 

3.1.2 Linking Multiuser PL/I-80 Applications . . . 3-1 

3.2 External Declaration of Access Manager Routines . . 3-2 

3.3 Coding Numeric Key Values 3-3 

3.4 Using the RECREATE. PLI Utility Program 3-4 

3.5 PL/I-80 Data File Example 3-5 

3.6 PL/I-80 DATABASE Source Code 3-9 

4 Using Access Manager with Pascal/MT+ Applications 

4.1 Linking Access Manager to Your Application Program 4-1 

4.1.1 Linking Single-user Pascal/MT+ Applications 4-1 

4.1.2 Linking Multiuser Pascal/MT+ Applications . 4-2 

4.2 External Declaration of Access Manager Routines . . 4-2 

4.3 Coding Numeric Key Values 4-2 

4.4 Using the RECREATE. SRC Utility Program 4-3 

4.5 Pascal/MT+ Data File Example 4-5 

4.6 Pascal/MT+ DATABASE Source Code 4-9 



Tables and Listings 



Tables 



1-1. 
1-2. 
1-3. 
1-4. 

2-1. 
2-2. 

3-1. 

4-1. 



Access Manager Code Requirements 1-4 

CP/M and MP/M II Design Constraints 1-5 

Queue Space Requirements 1-6 

Suggested Index File Record Lengths 1-8 

Example CB80 Recreate Parameter File 2-3 

Data Record Field 2-25 

Example PL/l-80 Recreate Parameter File .... 3-5 

Example Pascal/MT+ Recreate Parameter File. . . 4-4 



Listings 

2-1. 
2-2. 

3-1. 
3-2. 

4-1. 
4-2. 



CB80 Data File Example 2-4 

DATABASE. BAS Source Code 2-8 

PL/I-80 Data File Example 3-6 

DATABASE. BAS Source Code 3-10 

Pascal/MT+ Data File Example 4-5 

DATABASE. SRC Source Code 4-10 



Section 1 
Implementation Guidelines 



1.1 Main Access Manager Components 

Your Access Manager distribution disk contains the following 
files: 



Single-user subroutine libraries 

AM80CB80.IRL A complete, binary-relocatable, indexed 
library of index and data file routines for 
CB80 application programs. 

AM80PLI.IRL A complete, binary-relocatable, indexed 
library of index and data file routines for 
PL/I-80 application programs. 

AM80PASC.ERL A complete, binary-relocatable library of 
index and data file routines for Pascal/MT+ 
application programs. 



Single-user buffer modules 

AM80BUF.IRL A relocatable object module containing a 
prespecif ied buffer area of 3,560 (decimal) 
bytes for CB80 and PL/I-80 application 
programs. 

AM80BUF.ERL A relocatable object module containing a 
prespecified buffer area of 3,560 (decimal) 
bytes for Pascal/MT+ application programs. 

AM80BUF.ASM The assembly language source code for the 
buffer modules. Contains entry points 
(AM8FCB and AM8END) that define the 
beginning and end of the buffer area. 

SETAMBUF.COM A program to change the buffer module sizes 
without reassembling AM80BUF.ASM. 



External procedure declarations 

AM80EXTR.BAS External procedure declarations for CB80 
application programs. 

AM80EXTR.PLI External procedure declarations for PL/I-80 
application programs. 
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AM80EXTR.PSC External procedure declarations for 

Pascal/MT+ application programs. 



Multiuser application interfaces 

AMQ8CB80.IRL Relocatable interface module to coordinate 
compiled CB80 application programs and the 
shared Access Manager routines (AM80.PRL). 

AMQ8PLI.IRL Relocatable interface module to coordinate 
compiled PL/I-80 application programs and 
the shared Access Manager routines 
(AM80.PRL) . 

AMQIPASC.ERL Relocatable interface module to coordinate 
compiled Pascal/MT+ application programs 
and the shared Access Manager routines 
(AM80.PRL) . 



Background server routines 

AM80.PRL A page relocatable program containing all 

multiuser routines. AM80.PRL runs in its 
own memory segment as a shared, background 
server. 

STOPAM80 . PRL A page relocatable utility program that 
closes all open index and data files, 
terminates AM80.PRL, and releases its 
memory segment. 

AM80x.RSP Resident System Processes to include in the 
MP/M™operating system at system generation 
time (when GENSYS is run) . It sets up the 
interprocess queues for a multiuser system. 
For example, AM803.RSP reserves queues for 
up to three users. 



Background server customization routines 

The following files contain the code you need to create custom 
versions of AM80.PRL. Additional instructions can be found 
under "Creating Custom Background Servers" in Section 1.4.1. 



AM80MBUF.ASM 



AM80SERV.REL 



Determines the number and size of buffers 
and reserves the actual space for them. 
You can significantly affect the size of 
AM80.PRL by changing this module. 

Contains the message handling code that 
communicates with the multiuser interfaces 
to coordinate the sharing of Access Manager 
routines. 
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AM80B.IRL 



Contains the Access Manager routines for a 
multiuser environment. 



Host language data file routines 



CDATA.BAS 



These routines are similar to the data file 
functions described in Section 3 of your 
Reference Manual, except they are written 
in CB80 source code. (See Section 2, of 
the CBASIC Compiler (CB80) Language 
Programming Guide. ) 



Utility programs 



RECREATE 



DATABASE 



A general purpose program for rebuilding 
index and data files. Source versions of 
the program are provided in CB80, PL/I-80, 
and Pascal/MT+. Section 5 of your 
Reference Manual contains a complete 
description of the RECREATE utility 
program. 

A complete data base example for single-user 
or multiuser environments. Source code is 
provided in CB80, PL/I-80, and Pascal/MT+. 



1.2 Memory Requirements for Access Manager Code 

[SINGLE] The Access Manager modular design ensures that your 
application program uses only those parts of Access Manager that are 
actually required. The calls to Access Manager embedded in the 
application program determine which modules the linking loader 
brings into the final file. 

[MULTI] Only a small interface module combines with your 
application program. The actual Access Manager code resides in a 
separate memory segment. 

Table 1-1 shows the Access Manager code requirements for 
single-user and multiuser environments. The following standard 
abbreviations are used: B means bytes and K means kilobytes. 
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Table 1-1. Access Manager Code 


Requirements 




Module 


Memory 
SINGLE 


in 


Bytes 
MULT I 


Kernel: system initialization and 
index file setup and searching 


5.3K 







Key value insertion 


1.5K 







Key value deletion 


1.8K 







Data file routines 


2.6K 







Buffer Area 


0.6K+ 







Background server (w/o buffer area) 







16. 4K 


Minimal buffer area 







4.5K 


Application program interface 







2. OK 


Queue space requirements: 
for 3 users 
for 4 users 
for 6 users 
for 8 users 







768B 
1024B 
12 8 OB 
179 2B 



1.3 Access Manager Design Constraints 

When using Access Manager, the following design constraints 
apply in both single-user and multiuser environments: 

• Data records in a data file must all be the same length. 

• Data records must be a minimum of four bytes in length. 

• Access Manager reserves the first 128 bytes of every data file 
for recording status information. 

• Key values must not exceed a length of 48 bytes. 

• Data record numbers (pointers) associated with key values must 
not exceed a length of four bytes. 

• The length of an index file record must be a multiple of 128 
bytes; for example, 128, 256, 512, 1024, etc. 

• There must be a minimum of four key values in any given index 
file record. 

• A minimum of three buffers must be allocated for Access 
Manager . 
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If your application program runs under CP/M or MP/M II™ , 
observe the design constraints shown in Table 1-2. In the table 
megabyte is abbreviated as MB. 

Table 1-2. CP/M and MP/M II Design Constraints 



Design Constraint 


CP/M 


MP/M II 


Maximum number of key values 






per index file record 


124 


124 


Maximum index file size 


8 MB 


8 MB 


Maximum number of index files 






that can be open at a given time 


10 


40 


Maximum data file size 


8 MB 


32 MB 


Maximum number of data files 






that can be open at a given time 


20 


40 


Maximum number of Access Manager 






disk buffers 


18 


60 


Maximum number of users in a 






multiuser environment 


N/A 


8 



1.4 Multiuser Module under MP/M II 

Correct implementation of Access Manager under MP/M II requires 
proper use of the following components: 

AM80x.RSP creates the Access Manager queues. 

AM80.PRL contains the shared index file, data file, and 
buffer area. 



1.4.1 Creating Access Manager Queues 

The queues created by AM80x.RSP (where "x" = 3, 4, 6, or 8) 
coordinate the multiuser keyed file accessing requests. This queue 
space must be reserved in common memory, meaning memory that is 
accessible to all users. Table 1-3 shows the queue space memory 
requirements. 



1-5 



Access Manager Programmer *s Guide 



1.4 Multiuser Module 



Table 1-3. Queue Space Requirements 



Maximum Number 
of Users 



Module 
Name 



Memory 
in Bytes 



AM803.RSP 
AM804.RSP 
AM806.RSP 
AM808.RSP 



768 
1024 
1280 
1792 



For a given number of users, the task of reserving queue space 
need only be performed once during MP/M system generation. The MP/M 
utility program GENSYS.COM automatically prompts you to determine if 
a Resident System Process (any file with a .RSP extension) should be 
included in the operating system. To set up a three-user system for 
Access Manager, respond with Y, for Yes, when GENSYS prompts you 
about AM803.RSP. Respond with N, for No, when prompted about the 
other AM80x.RSP files. GENSYS prompts you about an RSP file only if 
such a file is on the GENSYS disk. 

After you complete the GENSYS procedure, a new MP/M system is 
written to a disk file (MPM.SYS) . The next time you boot the 
system, the new version of MP/M resides on disk. 

If there in not enough common memory for the Access Manager 
queue space and any other optional components of your operating 
system, GENSYS tells you and requests a retry. 

1.4.2 Invoking Shared Routines 

AM80.PRL contains the shared Access Manager code designed to 
run in its own memory segment under MP/M. As distributed, it 
requires less than 32K bytes of memory (although the AM80.PRL file 
is somewhat larger because it contains a byte relocation map) , 
supports up to forty index files and forty data files, and uses 
twenty buffers with a node size of 512 bytes (NNSEC% = 4). 
Instructions for changing this configuration can be found under 
"Creating Custom Background Servers" in Section 1.4.4. 

To start AM80.PRL under MP/M, type 

AM80 

If Access Manager starts successfully, a message similar to the 
following appears on your screen: 



ACCESS MANAGER (tm) 8080 
Serial No. AM-9999-000000 
Copyright (c) 1982,1983 



Version 1.1 

All Rights Reserved 

Digital Research, Inc. 



Access Manager (tm) is ready for y users, 
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Access Manager then detaches from the console and AM80.PRL is 
waiting in the background to service multiuser application programs. 

If Access Manager encounters a problem at start-up, one of the 
following messages appear on the console: 

Access Manager could not open queues. Has an Access Manager 
RSP been included at GENSYS? 

Access Manager Background Server (AM80.PRL) has illegal 
SETUP parameters. Check AM80MBUF.ASM for proper setup. 

Access Manager could not open lock file. Are the disk 
and/or directory full? 

Access Manager could not initialize lock file. Call 
Digital Research. 

1.4.3 Cancelling Shared Routines 

To close all open index and data files and free the memory 
segment occupied by AM80.PRL, type the command: 

STOPAM80 

If successful/ the following message appears on the console: 

Access Manager (tm) Terminated 

If AM80.PRL is not running when you attempt to start STOPAM80, 
this message appears on the console: 

Be sure that Access Manager is operational. Run MPMSTAT to 
see. 



1.4.4 Creating Custom Background Servers 

There are two parameters affecting the size of AM80.PRL that 
can be modified. These parameters are defined by DW statements in 
the AM80MBUF.ASM file. The parameters are the following: 

• NBUFS% The number of index file I/O buffers. NBUFS% must 

be set to at least three. However, 20 is a more 
realistic value for satisfactory multiuser 
operation. NBUFS% must not exceed 60. 

• NNSEC% The number of 128-byte sectors comprising each index 

file node. Must be at least one; four sectors are 
recommended . 
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Once you enter the appropriate values for the preceding 
parameters, you must change the amount of storage reserved by 
AM80MBUF. The storage is reserved with a DS statement. The amount 
of storage required is given by this expression: 

2504 + (NBUFS% * ((128 * NNSEC%) + 52)) 

After AM80MBUF.ASM is assembled, you can create a new AM80.PRL with 
the following command line: 

LINK AM80=AM80SERV[A,OP] ,AM80MBUF,AM80B.IRL[S] 



1.4.5 Data and Index Files 

When Access Manager runs in a multiuser environment, index and 
data files are opened in the locked mode. This places total control 
of these files under AM80.PRL. Further, the files are in the 
directory of the MP/M user area from which AM80.PRL is started. In 
most environments, AM80.PRL is started from user area zero. 

1.5 Configuring the Single-user Buffer Area 

The primary parameters affecting the buffer area size are 
NNSEC% (the number: of sectors per index file record) and NBUFS% (the 
number of index file buffers) . NNSEC% should be set to four if 
compatibility of your application program with other software is a 
factor. However, if response time is a more critical issue, refer 
to Table 1-4 for suggested NNSEC% values. 

Note that NNSEC% determines the length of the records in the 
index file. For example, if NNSEC% is four, the resulting index 
file record length is 512 bytes, regardless of the physical sector 
size of the disk. 



Table 1-4. Suggested Index File Record Lengths 


Physical Sector 
Size of Disk 


Suggested Values 
for NNSEC%* 


128 2 

256 2,4 

512 2,4 

1024 4,8 



* NNSEC% specifies the number of 128-byte sectors 
per index file record. 



Within the guidelines of Table 1-4, the selection of a value 
for NNSEC% is usually based on the length of the keys. Long keys 
lead to higher values of NNSEC% to reduce the levels of the B-Tree 
index structure. 
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For any specified value of NNSEC%, the more buffers (larger 
NBOFS%) there are, the fewer node accesses you need to retrieve a 
key value. However, when processing one index file at a time, the 
payoff from adding buffers diminishes rapidly when five or six 
buffers are already in use. If more than one index file is in use 
at a time, increase the number of buffers beyond six. Provided 
memory space is available, three buffers per index file (in active 
use at one time) is a reasonable guideline. Buffers are not 
assigned to individual index files. They are shared according to a 
least-recently-used priority scheme, which ensures the active index 
files make full use of the buffers. 

The amount of available memory determines the size of the 
buffer area. If there is very little memory available for buffers, 
you can reduce NBUFS% to the minimum level of three. 

The required buffer size for any given specification of the 
maximum number of index files (NKEYS%) , the node size (NNSEC%) , the 
number of buffers (NBUFS%) , and the number of data files (NDATF%) , 
can be calculated like this: 

((NKEYS% + NDATF%) * 44) + (NBUFS% * ( (NNSEC% * 128) + 52)) 

For example, if NKEYS%=3, NBUFS%=6, NDATF%=1, and NNSEC%=4, a 
buffer size of 3,560 (decimal) bytes is required. Once this buffer 
space is reserved, any combination of the four determining 
parameters that stays within 3,560 bytes can be passed to the SETUP 
routine, which sets up the way the buffer area is used. 

If you have the RMAC™ assembler, which generates relocatable 
object files (REL files) , you can change AM80BUF.ASM, then 
reassemble it to create a new AM80BUF.REL. Or, you can run the 
program SETAMBUF.COM, which is on your distribution disk. Just make 
sure AM80BUF.IRL and AM80BUF.ERL are on the same disk as 
SETAMBUF.COM. SETAMBUF modifies the buffer modules according to 
your specifications. 

End of Section 1 
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Section 2 
Using Access Manager 

with CBAS1C Compiler (CB80) Applications 



This section contains instructions for implementing Access 
Manager with application programs coded in CB80. 

There are two examples provided in this section. The first 
shows the use of many Access Manager functions described in Section 
3 of your Reference Manual, and how to use CB80 strings for data 
file buffer areas. The second example, DATABASE . BAS , illustrates 
the use of multiple index and data files. 

2.1 Linking Access Manager to Your Application Program 

This section discusses a CB80 application program call MYPROG 
that you write and compile to produce a binary relocatable file. 

2.1.1 Linking Single-user CB80 Applications 

You must link your compiled application program to the 
appropriate Access Manager subroutine library and index file buffer 
module. The following command line can be used to create an 
executable version of MYPROG: 

LK80 MYPROG,AM80CB80.IRL,AM80BUF.IRL 

AM80BUF contains the buffer area beginning with entry point AM8FCB 
and ending with AM8END. 

Because AM80CB80 and AM80BUF are indexed, relocatable 
libraries, LK80™ places them in the root module in case CB80 
overlay structures are used. Before linking, be sure AM80BUF is 
large enough to contain your buffers (as specified in the SETUP 
function) . You can use SETAMBUF to create a correctly sized buffer 
module. 



2.1.2 Linking Multiuser CB80 Applications 

If your single-user version of MYPROG is coded with appropriate 
data locking procedures, you do not have to recompile it to create a 
multiuser version. All that is necessary is to relink the program. 

You must link your compiled application program to the 
appropriate Access Manager multiuser interface. The interface makes 
the queue calls to the shared code in the background server. The 
background server resides in its own memory segment. 
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To create a COM file that calls the Access Manager background 
server, use the following command line: 

LK80 MYPROG,AMQ8CB80.IRL 

To create a PRL file that calls the Access Manager background 
server, use LINK.COM (which comes with MP/M II) as follows: 

LINK MYPR0G[0P,A] ,AMQ8CB80.IRL 

Note that if you use LINK.COM, your application program cannot 
use the CB80 overlay facility. 

No buffer area module (such as AM80BUF) is permitted in the 
multiuser link statement. Whereas AM80CB80 contains the actual 
Access Manager code, AMQ8CB80 simply contains the message handler 
necessary to get the shared Access Manager code (contained in 
AM80.PRL) to perform the necessary actions. 

2.2 External Declaration of Access Manager Routines 

CB80 requires that external routines (those not coded in the 
program module but referenced by it) be explicitly declared. The 
file AM80EXTR.BAS contains the external function declarations for 
the entire set of Access Manager functions. Use the %INCLUDE 
feature of CB80 to make these external declarations a part of your 
application program. 

2.3 Coding Numeric Key Values 

Refer to the discussion of "Coding Numeric Key Values" under 
the ADDKEY function description in Section 3 of your Reference 
Manual. 



2.4 Using the RECREATE. BAS Utility Program 

RECREATE. BAS contains the CB80 source code for the RECREATE 
utility program. You can change the source code in whatever way you 
want. 

To create RECREATE.COM, compile RECREATE. BAS using CB80 and 
then link as follows: 

LK80 RECREATE , AM80CB80 . IRL ,AM80BUF . IRL 

The buffer area for RECREATE is 4,600 bytes based on the 
following parameter values: 

• NNSEC% = 4 

• NBUFS% = 8 

• NDATF% = 1 

• NKEYS% = 1 
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Note that only one data file and one index file are open at the same 
time RECREATE is running. Use SETAMBUF to configure AM80BUF.IRL. 

Table 2-1 shows the layout and content of records in a Recreate 
Parameter File. This particular example file can be used to 
reconstruct DATABASE. BAS (see Listing 2-2). 

Table 2-1. Example CB80 Recreate Parameter File 



Record Type 


Contents 


Header 


1,4 


Data File 


CUSTOMER . DAT , 10 , 3 , 


Index File 


NAME. IDX, 10,0, 1,1, Y 


Key Part 


22,8 


Index File 


NUMB . IDX , 4 , , , 1 , N 


Key Part 


2,4 


Index File 


zipc.idx,ii,o,i,i,y 


Key Part 


84,9 



If you want to change the capacity of the RECREATE program, and 
hence its memory requirements, note the following parameters and 
associated DIMension statements: 



• MAX.NO.KEYS% and MAX . NO . KEY . PARTS % specify the maximum number 
of index files associated with a data file and the maximum 
number of fields comprising a key value, respectively. If the 
value for either of these parameters is increased in 
RECREATE .BAS , the following dimension statements must be 
modified to reflect the changes: 

DIM INDEX. NAME$( . . . 
DIM AUTO. SUFFIX% ( ... 

• MAX.SORT% determines the maximum number of key values that will 
be buffered by RECREATE. BAS before being sorted and added to 
the index file being recreated. If MAX.SORT% is increased, the 
following dimension statement must be changed. 

DIM KEYVAL$ ( . . . 

The routine SORT. SETUP in RECREATE. BAS uses the FRE and MFRE 
functions of CB80 to determine the amount of available memory for 
buffered key values. The actual number of key values buffered is 
stored in NO.SORT%. For long key lengths, the memory space 
available limits NO.SORT%. The value for N0.S0RT% can be made more 
conservative by reducing the values of G.SORT and M.SORT before 
NO.SORT% is computed. 
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2.5 CB80 Data File Example Listing 

In the following listing the CB80 SADD function determines the 
value of the buffer pointer (Access Manager parameter BUFFER%) for 
the READAT and WRTDAT routines. The result of SADD is increased by 
two because each string variable in CB80 has a two-byte header 
containing the length of the string. 

When Access Manager fills in the input buffer INP. BUFFERS 
during the READAT function, the two-byte length header is not 
affected. Therefore, you can use one such string input buffer for 
all the data files if it is long enough to accommodate the longest 
record length. 

However, the output buffer OUT.BUFFER$ is constantly adjusted 
because it is reconstructed for each WRTDAT function. Therefore, it 
is not advisable to use the input buffer for output. Reserve the 
input buffer for input only; create the output buffer strings as 
needed. 



REM 

REM AM80 External Declarations 

REM 

% INCLUDE AM80EXTR.BAS 

rE M ._ .__ 

REM Exception Processing Routines 

REM '■-— 

DEF ERROR. HANDLER (LOCALE) 
INTEGER LOCALE 

PRINT "ERROR at ";LOCALE;" with code "jERRCOD 
STOP 
FEND 

DEF LOCK. CONFLICT (LOCALE) 
INTEGER LOCALE 

PRINT "LOCK Conflict at ";LOCALE;" with code ";LOKCOD 
FEND 



Listing 2-1. CB80 Data File Example 
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2.5 CB80 Data File Listing 



REM 

REM Lock Parameter Setup 

REM 



N.LOCK% = REM No lock request 

S.LOCK% = 1 REM Shared record lock 

X.LOCK% = 2 REM Exclusive record lock 

S.FILE% = 3 REM Shared file lock 

X.FILE% = 4 REM Exclusive file lock 



REM 

REM System Initialization Parameters 

rem 



NBUF% = 3 REM 3 buffers 

NKEYS% = 1 REM 1 index file 

NNSEC% = 4 REM 512-byte index file record length 

NDATF% = 1 REM 1 data file 

ERROPT% = 1 REM Trap user errors 

PROGID% = -1 REM Program ID assigned to MP/M console no. 

TIMOUT% = 3 REM Background server time-out delay 



rem 

REM Initialize System 

REM 



PROGID% = INTUSR(PROGID%,ERROPT%,TIMOUT%) 
IF ERRCOD <> THEN \ 

CALL ERROR. HANDLER (1) 
IF SETUP (NBUF%,NKEYS%,NNSEC%,NDATF%) <> THEN \ 

CALL ERROR. HANDLER (2) 

REM : 

REM Open Files 

rem 

FILE.NO% = -1 REM Automatic file number assignment 

RECORD. LEN% = 32 

FILE.NAME$ = " K : PART . DAT " 

FILE.NO% = OPNDAT(FILE.NO%,S.FILE%,FILE.NAME$,RECORD.LEN%) 

IF ERRCOD <> THEN \ 

CALL ERROR. HANDLER (3) 
IF LOKCOD <> THEN \ 

CALL LOCK. CONFLICT (3) 

rem 

REM Create input buffer area and buffer pointer. The buffer 

REM pointer = SADD + 2 because SADD points to the two-byte 

REM length header which precedes the actual string. 

rem 

REM 12 3 

INP. BUFFER$ = n 12345678901234567890123456789012 n 
BUFFER. PTR% = SADD (INP.BUFFER$) + 2 
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REM 

REM Set exclusive lock on data record no. 65686 

REM 

DRN2% = 1 

CALL SETDAT(DRN2%) REM Set high-order bytes to 1 

REM which implies a base of 65536. 
DRN% = 150 REM 65686 = 65536 + 150 

IF SETLOK(FILE.NO%,X.LOCK%,DRN%) <> THEN \ 
CALL LOCK. CONFLICT (4) 

REM 

REM Read data record 

rem 

CALL SETDAT(DRN2%) 

IF READAT (FILE. NO%,DRN%, BUFFER. PTR%) <> THEN \ 
CALL ERROR. HANDLER (4) 

REM 

REM Parse buffer into working variables 

REM 

PART.NO$ = LEFT$(INP.BUFFER$,4) 
PART. NAMES = MID$ (INP. BUFFERS ,5 ,20 ) 
PART.QUAN = VAL(RIGHT$(INP.BUFFER$,8)) 

REM 

REM Update data record 

rem 

PART.QUAN = PART.QUAN - 100. 

REM 

REM Create output buffer 

REM 

OUT. BUFFERS = PART.NOS + PART. NAMES + \ 

LEFTS (STR$ (PART.QUAN) ,8) 
BUFFER. PTR% = SADD (OUT. BUFFERS) + 2 

REM 

REM Write updated record 

REM 

CALL SETDAT(DRN2%) 

IF WRTDAT(FILE.NO%,DRN%, BUFFER. PTR%) <> THEN \ 
CALL ERROR. HANDLER (5) 

REM 

REM Release record lock 

REM 

CALL SETDAT(DRN2%) 

IF FRELOK(FILE.NO%,X.LOCK%,DRN%) <> THEN \ 
CALL LOCK. CONFLICT (6) 
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REM 

REM Close data file and release file lock 

REM 



IF CLSDAT(FILE.NO%) <> THEN \ 

CALL ERROR. HANDLER (7) 
IP FRELOK(FILE.NO%,S.FILE%,0) <> THEN \ 

CALL LOCK. CONFLICT (7) 

STOP 



Listing 2-1. (continued) 



2.6 CB80 DATABASE Source Code 

Your Access Manager distribution disk contains sample code for 
building and maintaining a data base in CB80. The code is designed 
so you can add or substitute your own key attributes as required. 
The sample code is on your distribution disk in a file named 
DATABASE. BAS. 

DATABASE. BAS demonstrates the integration of Access Manager 
with CB80 applications. It builds a name and address data base and 
provides facilities for examining, updating, and/or listing the 
information contained therein. You might also want to use routines 
from DATABASE. BAS directly in your application programs. 

[SINGLE] To create DATABASE.COM, compile DATABASE. BAS with 
CB80.COM and link as follows: 

LK80 DATABASE, AM80CB80 . IRL,AM80BUF . IRL 

[MULTI] In the multiuser environment, your link statement 
should be entered as follows: 

LK80 DATABASE , AMQ8CB80 . IRL 
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Note that Listing 2-2 of DATABASE. BAS might not include recent 
changes. You should always treat the copy on your distribution disk 
as the definitive version. 



HEM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM DATABASE EXAMPLE VERSION 1.05 4/17/82 1411 

REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM INTERFACE TO AM80(tm) 

REM 

REM 

REM AM80EXTR.BAS CONTAINS THE EXTERNAL DEFINITIONS OF THE 

REM AM80 ROUTINES 

REM 

%INCLUDE AM80EXTR.BAS 

REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM SET-UP DATABASE FIELD & KEY DESCRIPTORS 

REM 

REM : :: ::::::::::::::::::::::::::::::::::::: : : : : : 

DIM FLD.NAME$(7) r FLD.LEN%(7) ,NEW.FLD$(7) ,OLD.FLD$(7) 

DIM FLD.PTR%(7) 

MAX.FIELD% = 7:N0.FIELDS% = MAX.FIELD% + 1 

YES% = 1 : NO% = 
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Fr.n. 


.NAME$(0) 


= 


"Customer Number" 


:FLD. 


.LEN%(0) 


= 


4 


Fr,r>, 


.NAME$(1) 


= 


"First Name" 


:FLD. 


.LEN%(1) 


= 


16 


Fr.n, 


.NAME$(2) 


= 


"Last Name" 


:FLD. 


.LEN%(2) 


= 


20 


Fr.n. 


.NAME$ (3) 


= 


"Street Address" 


:FLD. 


.LEN%(3) 


= 


20 


FLn. 


.NAME$(4) 


= 


"City" 


:FLn. 


.LEN%(4) 


= 


20 


FLn. 


.NAME$(5) 


= 


"State" 


:FLD. 


.LEN%(5) 


= 


I 


FLn. 


.NAME$(6) 


= 


"Zipcode" 


:FLD. 


.LEN%(6) 


= 


9 


FLn. 


,NAME$(7) 


= 


"Customer Status" 


:FLD. 


.LEN%(7) 


= 


8 



HIM KEY.NAME$(2) ,KEY.LEN%(2) ,KEY.MAP%(2) ,KEY.TYPE% (2) ,KEY.NUM%(2) ,KEY.DUP%(2) 
MAX.KEY% = 2 

KEY.LEN%(0)=10:KEY.TYPE%(0)=0:KEY.MAP%(0)=2 REM KEY = LAST NAME 
KEY.LEN%(1)=11:KEY.TYPE%(1)=0:KEY.MAP%(1)=6 REM KEY 1 = ZIPCODE 
KEY.LEN%(2)=4 :KEY.TYPE% (2) =0 : KEY.MAP% (2) =0 REM KEY 2 = CUST NUMBER 

UNIQ.KEY% = 2 REM USED IN TEST OF UNIQUENESS 

FOR KEY% = TO MAX.KEY% 

IF KEY% = UNIQ.KEY% THEN \ 

KEY.DUP%(KEY%) = NO% \ 
ELSE \ 

KEY.DUP%(KEY%) = YES% 
KEY.NAME$(KEY%) = FLD.NAME$ (KEY.MAP% (KEY%) ) 
NEXT KEY% 

DIM INDEX.NAME$(2) 
INDEX. NAME$(0) = "NAME.IDX" 
INDEX. NAME$(1) = "ZIPC.IDX" 
INDEX.NAME$(2) = "NUMB.IDX" 

NLOCK% = REM IGNORE LOCKS 
SLOCK % = 1 REM SHARED RECORD LOCK 
XLOCK% = 2 REM EXCLUSIVE RECORD LOCK 
SFILE% = 3 REM SHARED FILE LOCK 
XFILE% = 4 REM EXCLUSIVE FILE LOCK 
RLOCK% = 5 REM RELEASE SLOCK% OR XLOCK% 

REM 

REM +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 

REM 

REM BEGINNING OF UTILITY FUNCTIONS 

REM 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM CLEAR SCREEN ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF CLEAR. SCREEN% 

FOR DUMMY% = 1 TO 24 

PRINT 
NEXT DUMMY% 
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FEND 

REM :::::::::::::::::::::::::::::: 

REM 

REM MAIN MENU ROUTINE 

REM 

REM :::::::::::::::::::::::::::::: 



DEF MAIN.MENU% 

PRINT TAB (21); 
PRINT TAB ( 20 ) ; 
PRINT TAB (20); 
PRINT TAB (20); 
PRINT TAB (5) ;"1. 
PRINT TAB (5) ;"2. 
PRINT TAB(5) ;"3. 
PRINT TAB (5) ;"4. 
PRINT TAB (5) ;"5. 
PRINT TAB (5) ;"6. 



1000 



FEND 



AM80 (tin) DEMONSTRATION" :PRINT 
Customer Database Operations" 

Terminal ";TERMINAL% 
****************************<> • print :PI 
Enter New Customers" 
Scan/Update/Delete Customer Records" 
List Customer Records" 
Database Statistics" 
Save All Files & Restart Operations" 
Terminate Operations" : PRINT : PRINT 
INPUT "Enter desired operation number>>" ;OP% 
IF 0P%<1 OR OP%>6 THEN PRINT -.PRINT :GOTO 1000 
MAIN.MENU% = OP% 
RETURN 



REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM SELECT SEARCH KEY ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF SEARCH. KEY% 

DUMMY% = CLEAR. SCREEN% 

PRINT TAB ( 25 ); "Customer Database Search Keys":PRINT :PRINT 

FOR KEY% = TO MAX.KEY% 

KEY.NO% = KEY.% + 1 

PRINT. TAB(5) ;KEY.NO%;"- ";KEY.NAME$ (KEY%) 

NEXT KEY% 
1040 PRINT : PRINT 

INPUT "Enter desired key number>>" ;OP% 

IF 0P%<1 OR OP%>NO.KEYS% THEN 1040 

SEARCH. KEY% = OP%-l 

RETURN 
FEND 



REM 
REM 
REM 
REM 
REM 



ERROR HANDLING 



DEF ERROR. TYPE%(TYPE%) 
PRINT 
PRINT \ 
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PRINT 



PRINT 

PRINT 

PRINT 

PRINT "get 

PRINT 

PRINT 

PRINT 

PRINT 

PRINT 

PRINT 

PRINT 



"User Error #";ERRCOD;" occurred while trying to "; 

ON TYPE% GOTO 9210,9230,9250,9290,9300,9320,9330, \ 
9340,9350,9360,9370,9380,9390,9400,9410,9420 
"open "; INDEX. NAME? (KEY%) : GOTO 9700 
PRINT "search ";KEY.NAME? (KEY%) ; " Index File" : GOTO 9500 
PRINT "save "; INDEX. NAME$ (KEY%)' : GOTO 9600 
PRINT "remove old key from " ,° INDEX. NAME$ (KEY%) : GOTO 9500 
"enter key into "; INDEX. NAME$ (KEY%) :GOTO 9500 
"delete key from " ; INDEX. NAME$ (KEY%) :GOTO 9500 
'save ";FILE.NAME? :KEY% = -l:GOTO 9600 

new data record";" (" ;FILE.NO%; ") " :GOTO 9700 
"delete data record #";DRN% :GOTO 9700 
"open ";FILE.NAME$;" (" ;FILE.NO%; ") " :GOTO 9700 
'read data record #";DRN%:GOTO 9700 
'write data record." :GOTO 9700 

"release shared file lock on " ;FILE.NAME?:GOTO 9700 
"initialize user.": STOP 

"close ";FILE.NAME$ :KEY% = -l:GOTO 9600 
PRINT "close "; INDEX. NAME$(KEY%) : GOTO 9600 
CALL CLSDAT(FILE.NO%) 
FOR T.KEY% = TO MAX.KEY% 

IF T.KEY% <> KEY% THEN CALL CLSIDX (KEY.NUM% (T. KEY%) ) 
NEXT T.KEY% 

GOTO 9700 REM STOP ERROR MESSAGE 
T.KEY% = KEY% + 1 
IF T.KEY%>MAX.KEY% THEN STOP 
FOR KEY% = T.KEY% TO MAX.KEY% 

CALL CLSIDX (KEY. NUM% (KEY%) ) 
NEXT KEY% 
PRINT 

PRINT "DEMONSTRATION TERMINATING WITH ERROR CODE #";ERRCOD 
STOP 
FEND 
DEF LOCK.TYPE%(TYPE%) 

PRINT "Lock Type: ";TYPE%;" Lock Code : " ; LOKCOD 

CALL CLSDAT(FILE.NO%) 

FOR T.KEY% = TO MAX.KEY% 

CALL CLSIDX (KEY. NUM% (T.KEY%) ) 
NEXT T.KEY% 
STOP 
FEND 



9210 
9230 
9250 
9290 
930Q 
9320 
9330 
9340 
9350 
9360 
9370 
9380 
9390 
9400 
9410 
9420 
9500 



9600 



9700 



REM 
REM 
REM 
REM 
REM 



STRIP TRAILING BLANKS 



DEF STRIP. BLANKS? (OLD. VAL$,FLD%) 

FOR TEST% = FLD.LEN%(FLD%) TO 1 STEP -1 

IF MID$ (OLD.VAL$,TEST%,l) <> " " THEN \ 

STRIP. BLANKS? = LEFT? (OLD. VAL? ,TEST%) 
RETURN 
NEXT TEST% 
STRIP. BLANKS? = "" 



:\ 
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RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM READ DATA RECORD ROUTINE 

REM 

DEF READ.CUST%(DRN%) 

IF READAT(FILE.NO%,DRN%,INPBUF.PTR%) <> THEN \ 

DUMMY% = ERROR. TYPE% (11) 
OFFSET% = 2 REM SKIP DELETE FLAG FIELD 

FOR D.FLD% = TO MAX.FIELD% 

OLD.FLD.VAL$ = MID$ (INPBUF$ ,OFFSET%,FLD.LEN% (D.FLD%) ) 
OLD.FLD$(D.FLD%) = \ 

STRIP. BLANKS$ (OLD. FLD.VAL$,D.FLD%) 
OFFSET% = OFFSET% + FLD.LEN% (D.FLD%) 
NEXT D.FLD% 
RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM LIST CUSTOMER RECORD ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF PRINT. CUST% 

IF ROUTE$ = "Y" THEN \ 
LPRINTER 

PRINT 

PRINT TAB (5) ;OLD.FLD$(0) ;TAB(15) ;OLD.FLD$ (7) 

PRINT TAB (25) ;OLD.FLD$(l) ; " " ;OLD.FLD$ (2) 

PRINT TAB(25);OLD.FLD$ (3) 

PRINT TAB(25) ;OLD.FLD$ (4) ;" , " ;OLD.FLD$ (5) ; " " ;OLD.FLD$ (6) 

PRINT 

CONSOLE 

RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM PAUSE ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF PAUSE% 

PRINT 

INPUT "Press 'RETURN' to continue ";LINE PAUSE$ 

RETURN 
FEND 



REM 
REM 
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REM CONVERT TARGET VALUE TO KEY FORMAT ROUTINE 

REM 

REM :::::::::::::::::::::::::::::::::::::::: : ::::::: 

DEF KEY.FORMAT$(KEY%,TARGET$) 

IF UNIQ.KEY% = KEY% THEN \ 

KEY.FORMAT$ = TARGET$ :\ 
RETURN 
KL% = KEY.LEN%(KEY%) 
KEY.FORMAT$ = LEFT$ (TARGET$ + SPACE$ ,KL%-2) + \ 

CHR$(0) + CHR$(0) 
RETURN 
FEND 

REM :::::::::::::::: ::::::::::::::::::::::::::::::::::::::: 

REM 

REM COMPARE INDEX. KEY & U. VALUE ROUTINE 

REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF COMPARE% 

IF KEY% = UNIQ.KEY% THEN \ 

KL% = KEY.LEN%(KEY%) \ 
ELSE \ 

KL% = KEY.LEN%(KEY%)-2 
Cl$ = LEFT$( INDEX. KEY$ + SPACE$,KL%) 
C2$ = LEFT$(U.VALUE$ + SPACE$,KL%) 
IF Cl$<C2$ THEN \ 

COMPARE% = -1 :\ 

RETURN 
IF Cl$>C2$ THEN \ 

COMPARE% = 1 \ 
ELSE \ 

COMPARE % = 
RETURN 
FEND 

REM :::::::::!: i :: :s s !::: 5 !!!!::::: s :::::::::::::: : : : : : : 

REM 

REM CHECK LOCK ROUTINES 

REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF SKIP.LOCK% 

WHILE DRN% <> AND LOKCOD <> 

L.VALUE$ = LEFT$ (INDEX. KEY$ , KEY. LEN% (KEY%) ) 
INDEX. KEY$ = SET.LENGTH$ 

DRN% = AFTKEY(KEY.NUM%(KEY%) ,FILE.NO%,SLOCK%, \ 
L.VALUE$, INDEX. KEY$) 
WEND 
RETURN 
FEND 

DEF CHECK. LOCK% 
PRINT 
INPUT \ 
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"Enter a 'W if you want to wait for locked record (s)»"; \ 
LINE DOMMY$ 
IF UCASE$(DUMMY$) = "W" THEN \ 
CHECK. LOCK% = YES% :\ 
RETURN 
WHILE DRN% <> AND LOKCOD <> 

CONV.TARGET$ = LEPT$ (INDEX. KEY$, KEY .LEN% (KEY%) ) 

INDEX. KEY$ = SET.LENGTH$ 

IF OLD.ACTION$ = "CONT" THEN \ 

DRN% = AFTKEY (KEY. NUM%(KEY%), FILE. N0%, \ 

SLOCK%, CONV.TARGET$, INDEX. KEY$) \ 
ELSE \ 

DRN% = BEFKEY(KEY.NUM%(KEY%) ,FILE.NO%, \ 
SLOCK %, CONV.TARGET$, INDEX. KEY$) 
WEND 

CHECK. LOCK% = N0% 
RETURN 
FEND 

DEF SET.XLOCK$ (0P$) 

30010 IF SETLOK(FTLE.NO%,XLOCK%,DRN%) <> THEN \ 
PRINT : \ 

PRINT "Customer update on hold due to record lock" :\ 
INPUT \ 
"Enter 'W' if you want to wait or press 'RET' to cancel update>>"; \ 
LINE DUMMY$:\ 
DUMMY$ = UCASE$ (DUMMY$) \ 
ELSE \ 

DUMMY$ = "Ok" 
IF DUMMY$ = M W" THEN 30010 
IF DUMMY$ = "ok" AND OP$ = "S" THEN \ 

SET.XL0CK$ = "SAVE" 
IF DUMMY$ = "Ok" AND OP$ = "D" THEN \ 

SET.XL0CK$ = "DELT" 
IF DUMMY$ <> "ok" THEN \ 

SET.XL0CK$ = OLD.ACTION$ 
RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM CUST # UNIQUENESS TEST ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF TEST.UNIQUENESS% 

TEST$ = NEW.FLD$(KEY.MAP%(UNIQ.KEY%) ) 
TEST% = GETKEY(UNIQ.KEY%,0,NLOCK%,TEST$) 
IF LOKCOD <> THEN \ 

DUMMY% = LOCK. TYPE % (12) 
IF TEST% = THEN \ 

TEST.UNIQUENESS% = YES% \ 
ELSE \ 

TEST.UNIQUENESS% = NO% : \ 

PRINT : \ 

PRINT " *** Already Assigned ***" : \ 
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PRINT 
RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM UPDATE DATA FIELD ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF UPDATE. FIELD% (FIELD. N0%) 

FIELD. NO% = FIELD. N0%-1 
1050 PRINT 

PRINT "Input new " ;FLD.NAME$ (FIELD. NO%) ; 

INPUT ">>";LINE NEW. FLD$ (FIELD. NO%) 

IF FIELD. NO% = KEY.MAP%(UNIQ.KEY%) THEN \ 

NEW. FLD$ (FIELD. NO%) = RIGHT$ ("0000"+NEW.FLD$ (FIELD. N0%) , \ 
FLD.LEN% (FIELD. NO%) ) \ 
ELSE \ 

NEW. FLD$ (FIELD. NO%) = LEFT$ (NEW. FLD$ (FIELD. NO%) , \ 
FLD.LEN% (FIELD. N0%)) 

IF FIELD. NO% <> OR NEW. FLD$ (FIELD. NO%) = \ 

OLD. FLD$ (FIELD. NO%) THEN RETURN 
UNIQUE% = TEST. UNIQUENESS % 
IF NOT UNIQUE% THEN 1050 
RETURN 
FEND 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM WARNING MESSAGES 

REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF WARNING. TYPE% ( T YPE%, RET. CODE %) 

PRINT 

PRINT "WARNING. . .Return Code #" ; RET.CODE%; \ 
" occurred while trying to "; 

ON TYPE% GOTO 9930,9940,9950 
9930 PRINT "remove old key from "; INDEX. NAME$ (KEY%) 

DUMMY % = PAUSE % : RETURN 
9940 PRINT "enter key into "; INDEX. NAME? (KEY%) 

DUMMY% = PAUSE% : RETURN 
9950 PRINT "delete key from "; INDEX. NAME$ (KEY%) 

DUMMY% = PAUSE% : RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM ADD NEW KEY VALUE ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
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DEF ADD.KEY%(KEY%,DRN%) 

K.PLD% = KEY.MAP%(KEY%) 
OLD.KEY$ = OLD.FLD$(K.FLD%) 
NEW.KEY$ = NEW.FLD$(K.FLD%) 
REM 

REM REMOVE OLD KEY VALUE 
REM 

RET.CODE% = DELKEY (KEY . NUM% (KEY%) , FILE. NO%, \ 

XLOCK%,0LD.KEY$,DRN%) 
IF ERRCOD <> THEN \ 

DUMMY % = ERROR.TYPE%(4) 
IF LOKCOD <> THEN \ 

DUMMY% = LOCK.TYPE%(6) 
IF RET.CODE% <> 1 THEN \ 

DUMMY% = WARNING. TYPE%(1, RET. CODE%) 
REM 

REM ADD NEW KEY VALUE 
REM 

RET.CODE% = ADDKEY (KEY. NUM% (KEY%) , FILE. NO% , \ 

XLOCK%,NEW.KEY$,DRN%) 
IF ERRCOD <> THEN \ 

DUMMY% = ERROR.TYPE%(5) 
IF LOKCOD <> THEN \ 

DUMMY% = LOCK.TYPE%(7) 
IF RET.CODE% <> 1 THEN \ 

DUMMY% = WARNING. TYPE%( 2, RET. CODE%) 
RETURN 
FEND 

REM :::::::::::::::::::::::::::::::!::::::::::::::::::::::::::: 

REM 

REM WRITE NEW DATA RECORD ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF WRITE.CUST%(DRN%) 

OUTBUF$ = CHR$(0) REM CLEAR DELETE FLAG 

FOR D.FLD% = TO MAX.FIELD% 

OUTBUF$ = OUTBUF$ + LEFT$ (NEW.FLD$ (D.FLD%) + \ 
FLD.SPC$, FLD.LEN%(D.FLD%) ) 
NEXT D.FLD% 

OUTBUF.PTR% = SADD(OUTBUF$) + 2 
IF WRTDAT(FILE.NO%,DRN%,OUTBUF.PTR%) <> THEN \ 

DUMMY% = ERROR. TYPE% (12) 
RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM DELETE KEY VALUE FROM INDEX ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF DEL.KEY%(KEY%,DRN%) 

K.FLD% = KEY.MAP%(KEY%) 
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OLD.KEY$ = OLD.FLD$(K.FLD%) 

RET.CODE% = DELKEY(KEY.NUM%(KEY%) ,FILE.NO%, \ 

XLOCK % , OLD . KEY$ , DRN% ) 
IF ERRCOD <> THEN \ 

DUMMY% = ERR0R.TYPE%(6) 
IF LOKCOD <> THEN \ 

DUMMY % = LOCK.TYPE%(10) 
IF RET.CODE% <> 1 THEN \ 

DUMMY% = WARN ING . TYPE %( 3, RET. CODE %) 
RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM DATA ENTRY ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF ENTER. DATA$ (ENTER. MODE$) 

IF ENTER. MODE$ = "NEW" THEN \ 

FOR FLD% = TO MAX.FIELD% : \ 
OLD.FLD$ (FLD%) = "" : \ 
NEXT FLD% 
IF ENTER. MODE$ = "OLD" THEN \ 

FOR FLD% = TO MAX.FIELD% : \ 

NEW.FLD$(FLD%) = OLD. FLD$ (FLD%) : \ 
NEXT FLD% 
DUMMY% = CLEAR. SCREEN% 
WHILE ENTER. MODE$ = "NEW" 

PRINT TAB ( 20 ); "Enter New Customer Information" 
PRINT TAB(20);" ******************************" 
PRINT : PRINT 
PRINT TAB (5) ; \ 

"[Press 'RETURN' for customer # to see main menu.}" 
PRINT 

FOR FLD% = TO MAX.FIELD% 
FLD.NO% = FLD% + 1 
1010 PRINT TAB(4);FLD.NO%;"- " ;FLD.NAME$ (FLD%) ; \ 

TAB (30) ;"(";FLD.LEN%(FLD%) ; " ) " ;TAB (38) ; 
INPUT ">>";LINE NEW.FLD$ (FLD%) 
IF FLD% = AND NEW.FLD$ (FLD%) = "" THEN \ 
ENTER. DATA$ = "STOP" : \ 
RETURN 

IF FLD% = KEY.MAP%(UNIQ.KEY%) THEN \ 

NEW.FLD$ (FLD%) = RIGHT$ ("0000"+NEW. FLD$ (FLD% ) ,\ 

FLD.LEN%(FLD%)) :\ 
UNIQUE% = TEST. UNIQUENESS % \ 
ELSE \ 

NEW.FLD$ (FLD%) = LEFT$ (NEW.FLD$ (FLD%) , \ 

FLD.LEN%(FLD%) ) :\ 
UNI QUE % = YES% 

IF NOT UNIQUE% THEN GOTO 1010 
NEXT FLD% 
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# to change data," 
for back scan, or E" ; \ 



ENTER. MODE$ = "NEWMOD" 

WEND 

PRINT : PRINT : PRINT 

PRINT TAB(20) ;"Current customer information" : PRINT 

FOR FLD% = TO MAX.FIELD% 
FLD.NO% = FLD% + 1 

PRINT TAB (4) ;FLD.NO%; "- " ;FLD.NAME$ (FLD%) ;TAB (30) ; \ 
NEW.FLD$(FLDS) 

NEXT FLD% 
NEW DATA HAS FEWER OPTIONS 

IF ENTER. MODE$ = "NEWMOD" THEN 1030 

PRINT : PRINT 

PRINT \ 
3S 'RETURN' to continue scan, enter Field 

PRINT \ 
3 save changes, D to delete data, B 
" to end scan" ; 

INPUT ">>";LINE OP$ 

OP$ = UCASE? (OP$) 

IF OP$ = "" THEN ENTER. DATA$ = "CONT" : RETURN 

IF OP$ = "S" THEN ENTER. DATA$ = SET. XLOCK$ (OP$ ): RETURN 

IF OP$ = "D" THEN ENTER. DATA$ = SET .XLOCK$ (OP$) : RETURN 

IF OP$ = "B" THEN ENTER. DATA$ = "BACK" : RETURN 

IF OP$ = "E" THEN ENTER. DATA$ = " STOP ": RETURN 

OP% = VAL(OP$) 

IF 0P%<1 OR OPS>NO.FIELDSS THEN 1020 

DUMMY% = UPDATE. FIELDS (OPS) 

GOTO 1015 REM DISPLAY INFO 

PRINT : PRINT 

PRINT \ 
3S 'RETURN' to save data, enter Field # to change data," 

INPUT "D to delete data, or E to end input>>" ;LINE OP$ 

OP$ = UCASE$ (OP$) 

IF OP$ = "" OR OP$ = "S" THEN ENTER. DATA$ = "SAVE" : RETURN 

IF OP$ = "D" THEN ENTER. DATA$ = "DELT" : RETURN 

IF OP$ = "E" THEN ENTER. DATA$ = "STOP" : RETURN 

OP% = VAL(OP$) 

IF 0P%<1 OR OP%>NO.FIELDS% THEN 1030 

DUMMY% = UPDATE. FIELD% (OPS) 

GOTO 1015 



FEND 



REM :::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM UPDATE INDICES & DATA FILE ROUTINE 

REM 

REM ::::::::::::::::::::::::::.:::::::::::::::::::::::: 

DEF UPDATE % ( DATA . RECORD % ) 

IF DATA. RECORDS = THEN \ 

DATA. RECORDS = NEWREC (FILE.NOS ,XLOCK%) 
UPDATES = DATA. RECORDS 
IF ERRCOD <> THEN \ 

DUMMYS = ERROR. TYPES (8) 
IF LOKCOD <> THEN \ 
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DUMMY% = L0CK.TYPE%(3) 
FOR KEY% = TO MAX.KEY% 

FLD% = KEY.MAP%(KEY%) 

IF OLD.FLD$ (FLD%) <> NEW.FLD$ (FLD%) THEN \ 

DUMMY% = ADD. KEY%(KEY%, DATA. RECORD%) 
NEXT KEY% 
FOR FLD% = TO MAX.FIELD% 

IF OLD.FLD$ (FLD%) <> NEW.FLD$ (FLD%) THEN \ 

DUMMY% = WRITE. CUST% (DATA. RECORD%) :\ 
RETURN 
NEXT FLD% 
RETURN 
FEND 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM DELETE INDEX & DATA FILE ENTRY ROUTINE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

DEF DELETE%(DATA.RECORD%) 

FOR KEY% = TO MAX.KEY% 

FLD% = KEY.MAP%(KEY%) 

IF OLD.FLD$ (FLD%) <> " " THEN \ 

DUMMY % = DEL. KEY %( KEY %, DATA. RECORD %) 
NEXT KEY% 
IF RETREC(FILE.NO%,XL0CK%,DATA.REC0RD%) <> THEN \ 

DUMMY% = ERROR.TYPE%(9) 
IF LOKCOD <> THEN \ 

DUMMY% = LOCK.TYPE%(9) 
RETURN 
FEND 

REM END OF UTILITY FUNCTIONS 

REM 

REM ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 

REM 

REM :: J :::::::::: s :: : :::::::::::::::::::::::::::::::: ::::::: :::::: 

REM 

REM INITIALIZE INDEX FILES 

REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

2000 

SET.LENGTH$ = "12345678901" 

INDEX. KEY$ = SET.LENGTH$ 

SPACE$ = 
REM 

REM SET TERMINAL TO -1 FOR AUTOMATIC ASSIGNMENT BY AM80 
REM 

TERMINAL% = -1 

TRAP. ERRORS % = YES% 

TIME. OUT. TEST. DELAY% = 2 REM APPROXIMATELY 2 SECONDS 

TERMINAL% = INTUSR( TERMINAL %, TRAP .ERRORS% , TIME. OUT. TEST. DELAY%) 

IF ERRCOD <> THEN \ 

DUMMY% = ERROR. TYPE% (14) 
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NO. BUFFERS % = 5 

NO. NODE. SECTORS % = 4 

NO. DATA. FILES % = 1 

NO.KEYS% = MAX.KEY% + 1 

IF SETUP(NO. BUFFERS'*, NO. KEYS%, NO. NODE. SECTORS%, \ 

NO.DATA.FILES%) <> THEN \ 

PRINT "Illegal SETUP Parameters" :\ 

STOP 

FOR KEY% = TO MAX.KEY% 

KEY.NUM%(KEY%) = OPNIDX (-1, INDEX. NAME$ (KEY%) , \ 

KEY.LEN%(KEY%) , KEY.TYPE% (KEY%) ,KEY.DUP% (KEY%) ) 
IF ERRCOD <> THEN \ 

DUMMY % = ERR0R.TYPE%(1) 
NEXT KEY% 
REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
REM 

REM < INITIALIZE DATA FILE 
REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
FILE.NO% = -1 
RECORD. LENGTH % =100 
FILE.NAME$ = "CUSTOMER.DAT" 

FILE.NO% = OPNDAT(FILE.NO%,SFILE%, FILE. NAME$, RECORD. LENGTH%) 
IF ERRCOD <> THEN \ 

DUMMY% = ERROR. TYPE% (10) 
IF LOKCOD <> THEN \ 

DUMMY% = L0CK.TYPE%(1) 
4990 REM INITIALIZE STRING UTILITIES 
TMPBUFS = "12345678901234567890123456789012345678901234567890" 

INPBUF$ = TMPBUF$ + TMPBUF$ 
REM 

REM INPBUF IS THE BUFFER AREA FOR THE READAT ROUTINE 
REM 

INPBUF. PTR% = SADD(INPBUF$) + 2 

REM 123456789012345678901234567890123456 

FLD.SPC$ = " " 

REM 
REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

REM 

REM BEGIN DATABASE OPERATION 

REM 

5000 DUMMY% = CLEAR. SCREEN% 

CHOICE% = MAIN.MENU% 

ON CHOICE% GOTO 5100,5300,5500,5700,5900,6100 
REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
REM 
REM ENTER NEW CUSTOMERS 
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REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

5100 ACTI0N$ = ENTER. DATA$ ("NEW") 
LOCK. CODE % = 
IF ACTIONS = "SAVE" THEN \ 

NDRN% = UPDATE%(0): \ UPDATE INDICES & DATA FILE 
LOCK.CODE% = FRELOK(FILE.NO%,XLOCK%,NDRN%) 
IF LOCK.CODE% <> THEN \ 

DUMMY% = LOCK.TYPE%(8) 
IF ACTION$ = "SAVE" THEN \ 

GOTO 5100 \ 
ELSE \ 

GOTO 5000 REM RETURN TO MENU 
REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
REM 

REM SCAN/UPDATE/DELETE CUSTOMERS 

REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
5300 KEY% = SEARCH. KEY% REM DETERMINE SEARCH KEY 
PRINT 

PRINT "Enter target value for "; KEY. NAMES (KEY%) ;", " 
INPUT " or press 'RETURN' to see main menu>>"; \ 

LINE TARGET$ 
IF TARGET$ = "" THEN 5000 

CONV. TARGET $ = KEY. FORMAT $ (KEY% , TARGET $) 
5345 DRN% = SERKEY (KEY. NUM% (KEY%) , FILE .NO%,SLOCK% , \ 
CONV . TARGET$ , INDEX . KEY$ ) 
IF ERRCOD <> THEN \ 

DUMMY% = ERROR.TYPE%(2) 
IF LOKCOD <> THEN \ 

STAYPUT% = CHECK. LOCK% \ 
ELSE \ 

STAYPUT% = NO% 
IF STAYPUT% THEN 5345 
OLD.ACTION$ = "CONT" 
CONTINUE% = YES% 
WHILE CONTINUE% AND DRN% <> 

LDRN% = DRN% REM save drn for lock release 

DUMMY% = READ.CUST%(DRN%) 

ACTION$ = ENTER. DATA$ ("OLD") 

SAVE.KEY% = KEY% 

IF ACTION$ = "SAVE" THEN \ 

DUMMY% = UPDATE%(DRN%) 
IF ACTIONS = "DELT" \ 

THEN DUMMY% = DELETE% (DRN%) 
IF ACTIONS <> "DELT" AND FRELOK (FILE .NO% ,RLOCK%,LDRN%) <> \ 

THEN DUMMY% = LOCK.TYPE% (2) 
IF ACTIONS = "SAVE" OR ACTIONS = "DELT" THEN \ 
KEY% = SAVE. KEY % : \ RESET SEARCH KEY 
ACTIONS = OLD. ACTIONS REM reset direction 
OLD. ACTIONS = ACTIONS 

CONV. TARGETS = LEFTS (INDEX. KEYS , KEY. LEN% (KEY%) ) 
INDEX. KEYS = SET. LENGTHS 
LOCK.CODE% = 
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5390 IP ACTI0N$ = "CONT" THEN \ 

DRN% = AFTKEY (KEY. NUM% (KEY%) , FILE. NO%, \ 

SLOCK %, CONV.TARGET$, INDEX. KEY$) :\ 
LOCK. CODE % = LOKCOD 
IF ACTION$ = "BACK" THEN \ 

DRN% = BEFKEY (KEY. NUM% (KEY%) , FILE. NO%, \ 

SLOCK%, CONV.TARGET$, INDEX. KEY$) :\ 
LOCK. CODE % = LOKCOD 
IF LOCK.CODE% <> THEN \ 

STAYPUT% = CHECK. LOCK% \ 
ELSE \ 

STAYPUT% = NO% 
IF STAYPUT% THEN 5390 
IF ACTION$ = "STOP" THEN \ 
CONTINUE% = NO% 
WEND 
PRINT 

PRINT "SCAN ENDED" 
DUMMY % = PAUSE % 

GOTO 5000 REM RETURN TO MAIN MENU 
REM 

REM :::::'::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
REM 

REM LIST CUSTOMERS 

REM 

REM :::::::::::::::::::::::::::::::::::::::::::::::::: ; ::: t :::::: : 
5500 KEY% = SEARCH. KEY% 
PRINT 
INPUT \ 
"Do you want listing routed to printer (Y/N) >>" ;LINE ROUTE$ 
ROUTES = UCASES (ROUTES) 
PRINT 
PRINT \ 
"Enter lower and upper limits for " ;KEY.NAME$ (KEY%) ; " listing;" 

INPUT \ 
" separate values with a comma >>" ;L. VALUES, u. VALUES 
L.VALUE$ = KEY. FORMATS (KEY %,L. VALUE$) 
U. VALUES = KEY. FORMATS (KEY %,U. VALUES) 
DRN% = SERKEY(KEY.NUM%(KEY%) ,FILE.NO%,SLOCK%, \ 

L. VALUES, INDEX. KEYS) 
IF LOKCOD <> THEN \ 

DUMMY% = SKIP.LOCK% 
NO.LISTED% = 

WHILE DRN% <> AND COMPARE%< = 
DUMMY % = READ.CUST%(DRN%) 
DUMMY% = PRINT. CUST% 
NO.LISTED% = NO.LISTED% + 1 
IF FRELOK(FILE.NO%,SLOCK%,DRN%) <> THEN \ 

DUMMY% = LOCK.TYPE%(4) 
L. VALUES = LEFTS (INDEX. KEYS, KEY. LEN%(KEY%) ) 
INDEX. KEYS = SET. LENGTHS 
DRN% = AFTKEY (KEY. NUM%(KEY%) ,FILE.NO% ,SLOCK% , \ 

L .VALUES , INDEX . KEYS ) 
IF LOKCOD <> THEN \ 

DUMMY% = SKIP.LOCK% 
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WEND 

IF DRN% <> THEN \ 

LOCK.CODE% = FRELOK(FILE.NO%,SLOCK%,DRN%) \ 

ELSE \ 

LOCK.CODE% = 

IF LOCK.CODE% <> THEN \ 

DUMMY% = L0CK.TYPE%(5) 

PRINT 

PRINT TAB(5) ;NO.LISTED% ; " records listed." 

DUMMY % = PAUSE % 

GOTO 5000 REM RETURN TO MAIN MENU 
REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::: i :::::::::::: : 
REM 

REM DATABASE STATISTICS 

REM 

REM : ::::::::::::::::::::::::::::::::::::::::::::::::::::::: 

5700 DUMMY% = CLEAR. SCREEN% 

PRINT TAB(5) ;FILE.NAME$ ; " has " jGETDFS (FILE.NO%) ; \ 
" records; currently, "; 

PRINT GETDFU(FILE.NO%) j" of them are in use." 

PRINT : PRINT : PRINT -.PRINT 

PRINT TAB(5) ; "INDEX" ; TAB (30) /"ENTRIES" 

PRINT TAB(5) ;" ";TAB(30) ;" " 

FOR KEY% = TO MAX.KEY% 

PRINT TAB(5) ;KEY.NAME$ (KEY%) ;TAB(32) ;NOKEYS (KEY%) 

NEXT KEY% 

PRINT : PRINT : PRINT : PRINT 

DUMMY% = PAUSE% 

GOTO 5000 REM RETURN TO MAIN MENU 
REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
REM 

REM SAVE DATABASE UPDATES & RESTART 

REM 

REM ::::::::: ::::::: :t t ::::::::: :::::::::::::::::::::::::::::::: : 
5900 IF SAVDAT(FILE.NO%) <> THEN \ 
DUMMY% = ERROR.TYPE%(7) 

FOR KEY% = TO MAX.KEY% 

IF SAVIDX(KEY.NUM%(KEY%) ) <> THEN \ 
DUMMY% = ERROR.TYPE%(3) 

NEXT KEY% 

GOTO 5000 
REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
REM 

REM SAVE DATABASE UPDATES & TERMINATE 

REM 

REM ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 
6100 IF CLSDAT(FILE.NO%) <> THEN \ 
DUMMY = ERROR. TYPE% (15) 

FOR KEY% = TO MAX.KEY% 

IF CLSIDX(KEY.NUM%(KEY%) ) <> THEN \ 
DUMMY% = ERROR. TYPE% (16) 

NEXT KEY% 



IF FRELOK(FILE.NO%,SFILE%,0) <> THEN \ 

DUMMY % = ERROR. TYPE%( 13) 
PRINT 

PRINT " *** SUCCESSFUL TERMINATION ***" 
STOP 
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2.7 CB80 Source Code Data File Routines 

The CB80 data file routines presented in this section can be 
used to 

• Open a data file. 

• Close a data file. 

• Get space for new records. 

• Report the size of a data file. 

• Return space from deleted records. 

Note: use CB80 routines only in single-user environments because 
the Access Manager data locking facilities apply only to data file 
routines. Furthermore, the routines to keep track of deleted 
records and determine the next available record are not designed for 
multiuser environments. 



2.7.1 OPEN. DATA. FILE % (DATA. FILE$ , FILE. N0%, RECORD. LENGTH%) 

This routine opens DATA.FILE$ with the specified RECORD . LENGTH% 
as FILE.NO%. If DATA.FILE$ does not exist, it is created. The 
RECORD. LENGTH % must be the same each time the file is opened and it 
must be at least nine bytes. 

Note: no data can be stored in the first record of DATA.FILE$. The 
first record is a header that maintains the status of the DATA.FILE$ 
stack structure. 

FILE.NO% is constrained by the limitations of CB80 because 
DATA.FILE$ is a standard CB80 disk file. 

DUMMY%=OPEN. DATA. FILE%("D: CUSTOMER. DAT", 4, 128) 

The above call opens the specified data file as file number 
four with a record length of 128 bytes. If CUSTOMER.DAT does not 
exist on drive D, it is created. 

2.7.2 CLOSE. DATA. FILE % (FILE. NO%) 

This routine closes data files previously opened with a call to 
OPEN. DATA. FILE%. It must be used to close such files or the header 
record will be improperly updated. 

DUMMY%=CL0SE.DATA.FILE%(4) 

2.7.3 NEW. DATA% (FILE. N0%) 

This routine returns the record number of the next available 
record in the DATA.FILE$ opened as FILE.NO%. The next available 
record is removed from the top of the stack for FILE.NO%. If the 
stack is empty, NEW.DATA% automatically increments the size of the 
data file to generate space for a new record. For example, 
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DUMMY%=OPEN. DATA. FILE% ("D: CUSTOMER. DAT" ,4,128) 
INPUT "Enter new customer number and last name:"; \ 

CUST . NO , LAST . NAME $ 
DRN %=NEW . DATA% ( 4 ) 
CUST.NO$=CONVERT$ (CUST. NO ,2) 
RET .CODE %=ADDKEY (0,0,0 ,CUST .NO$ ,DRN%) 
IF ERRCODOO THEN DUMMY%=TROUBLE% (4) 
IF RET.C0DE%<>1 THEN DUMMY%=WARNING% (4 ,RET.CODE%) 
RET . CODE%=ADDKEY (1,0,0 ,LAST .NAME$ , DRN% ) 
IF ERRCODOO THEN DUMMY %=TROUBLE % ( 5 ) 
IF RET.C0DE%<>1 THEN DUMMY %=WARNING% (5 ,RET.CODE%) 
PRINT # 4, DRN %; CUST. NO, LAST. NAME $ 



In the preceding example, DRN% is set to the value of an empty 
record in the customer data file. A new customer number and last 
name are then added to the corresponding B-Trees with the associated 
record number given by DRN%. Finally, record DRN% in the customer 
data file is initialized. 

If a user error occurs, control transfers to TROUBLE% for 
appropriate action. The parameter in TR0UBLE% is a code to let the 
function know where the user error occurred. Control passes to 
WARNING?; if the ADDKEY functions are not successful. Both the 
location code and the RET.CODE% pass to WARNING?; . Note that you 
must provide both of these routines because they are not part of 
Access Manager. 

2.7.4 RETURN . DATA% (FILE . NO% , DATA . RECORD % ,MESSAGE$ ) 

This routine pushes the returned DATA.RECORD% to the top of the 
stack for FILE.NO%. Deleted data records are organized according to 
a stack structure, that is, last-in/first-out (LIFO) . After a call 
to RETURN. DATA%, the record in the data file with record number 
DATA.RECORD% has these two fields overwritten: 



Table 2-1. Data Record Fields 



Field 



Data 



Link to next available 
data record. 

MESSAGE $. 



You can use the MESSAGE$ parameter to flag deleted (returned) 
records or to save information from the deleted record for 
subsequent processing. 
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You might find it necessary to add enough trailing commas to 
MESSAGE$ so a deleted record has a full complement of data fields. 
This allows returned records to be read with the same read 
statements as regular records. This is shown in the following code 
segment: 

INPUT "Enter customer number:" ;CUST. NO 

CUST.NO$=CONVERT$ (CUST.N0,2) 

DRN%=GETKEY (0,0,0 ,CUST .NO$ ) 

IF DRN%<>0 THEN \ 

IF DELKEY(0,0,0,CUST.NO$,DRN%) = 1 THEN \ 
DUMMY%=RETURN .DATA% (4 ,DRN% , "DELETED ,,,,,,,") 

In the preceding example, the data record corresponding to 
CUST.NO$ returns to the data file for future use and the customer 
number is deleted from the index file, unless no such customer 
number exists. 



2.7.5 DATA. FILE. SIZE% (FILE. NO%) 

This routine returns the total number of records used by a data 
file, including the header record and any returned but unused 
records. 



2.7.6 DATA . FILE . DTI LI ZATION% (FILE . NO% ) 

This routine returns a count of the number of records in a data 
file currently being used to store data. It excludes the header 
record and any returned but unused records. 

End of Section 2 
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Using Access Manager with PL/I-80 Applications 



This section contains instructions for implementing Access 
Manager with application programs coded in PL/I-80. 

Two examples are provided in this section. The first shows how 
to use many of the Access Manager functions described in Section 3 
of your Reference Manual, and how to use the data file routines in 
your PL/I-80 applications. The second example provides an extensive 
illustration of using Access Manager to construct and maintain a 
data base. 



3.1 Linking Access Manager to Your Application Program 

This section discusses a PL/I-80 application program called 
MYPROG that you write and compile to produce a binary relocatable 
file. 



3.1.1 Linking Single-user PL/I-80 Applications 

You must link your compiled application program to the 
appropriate Access Manager subroutine library and index file buffer 
module. The following command line can be used to create an 
executable version of MYPROG: 

LINK MYPROG, AM80PLI . IRL [S, A] ,AM80BUF.IRL 

AM80BUF contains the buffer area beginning with entry point AM8FCB 
and ending with AM8END. 

Before linking, be sure AM80BUF is large enough to contain your 
buffers (as specified in the SETUP function) . You can use SETAMBUF 
to create a correctly sized buffer module. 

3.1.2 Linking Multiuser PL/I-80 Applications 

If your single-user version of MYPROG is coded with appropriate 
data locking procedures, you do not have to recompile it to create a 
multiuser version. All that is necessary is to relink the program. 

You must link your compiled application program to the 
appropriate Access Manager multiuser interface. The interface makes 
the queue calls to the shared code in the background server. The 
background server resides in its own memory segment. 
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To create a PRL file that calls the Access Manager background 
server, use LINK.COM as follows: 

LINK MYPR0G[0P,A] ,AMQ8PLI.IRL 

3.2 External Declaration of Access Manager Routines 

PL/I-80 requires that external routines (those not coded in the 
program module but referenced by it) be explicitly declared. The 
file AM80EXTR.PLI contains external function declarations for the 
entire set of Access Manager routines. Use the %INCLUDE feature of 
PL/I-80 to make these external declarations a part of your 
application program. 

Note that AM80EXTR.PLI expects two compile-time constants to be 
defined with the %REPLACE macro of PL/I-80. NAME_LEN (the maximum 
length of index and data filenames) and MAX_KEY_LEN (the maximum key 
value length) must be set to appropriate values before AM80EXTR.PLI 
is included. For example, the following code segment can be used: 

% REPLACE 

NAME_LEN BY 14, 
MAX_KEY_LEN BY 48; 

%INCLUDE 'AM80EXTR.PLI' ; 

It is not necessary to set MAX_KEY__LEN at the Access Manager maximum 
of 48. Any value less than or equal to 48 that is sufficient for 
your particular application is valid. 

Note: consider these points concerning the passing of parameters 
between Access Manager and PL/I-80: 

• Access Manager requires all string-valued parameters (FILNAME, 
IDXNAME, KEYVAL, and IDXVAL) to be declared as CHARACTER () 
VARYING. CHARACTER VARYING strings in PL/I-80 reserve the 
leading byte for a length counter Access Manager uses to 
determine the actual length of a string-valued parameter. 

• The output string parameter IDXVAL must be passed by reference, 
as opposed to value. Therefore, the actual parameter passed to 
Access Manager (for IDXVAL) must be declared with exactly the 
same attributes as the formal IDXVAL parameter in AM80EXTR.PLI. 
This implies the actual variable used for IDXVAL 
(ACTUAL_IDXVAL) must be declared as follows: 

DCL 

ACTUAL IDXVAL CHAR (MAX KEY LEN) VAR; 
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3.3 Coding Numeric Key Values 

For a general discussion of coding numeric key values, refer to 
the ADDKEY function description in Section 3 of your Reference 
Manual. 

In the PL/I environment, the easiest approach to represent 
numeric key values is to use FIXED DECIMAL quantities. Because 
FIXED DECIMAL quantities are stored in BCD (Binary Coded Decimal) 
format with the least significant byte first and the sign bit set in 
the last byte, KEYTYP% should be one. Access Manager requires a 
CHARACTER VARYING value for the KEYVAL$ and IDXVAL$ parameters. 
Therefore, FIXED DECIMAL variables should be overlayed (based) on 
KEYVAL$ and IDXVAL$ string variables. 

The key length is based on the number of bytes required to 
store the FIXED DECIMAL quantities. A FIXED DECIMAL with 'p' digits 
requires: 

INT((p + 2) / 2) 

bytes where INT returns the integer portion of its argument. For 
example, a FIXED DECIMAL quantity with eight digits requires five 
bytes of storage. 

The following declarations and assignments permit the use of 
FIXED DECIMAL quantities as key values in Access Manager. 



%REPLACE 




MAX KEY LEN BY 48, 




NAME LEN BY 14, 




P BY 8, 


/* 


Q BY 2, 


/* 


KEYLEN BY 5; 


/* 



example precision */ 
fractional places */ 
INT((P+2)/2) */ 

%INCLUDE 'AM80EXTR.PLI' ; 

DCL 

(KEYVAL,IDXVAL) CHAR (MAX_KEY_LEN) VAR, 
(BCDINP PTR,BCDOUT PTR) POINTER; 



DCL 



BCDINP BASED (BCDINP_PTR) , 
2 LEN FIXED BINARY (7), 
2 VAL FIXED DECIMAL (P,Q), 

BCDOUT BASED (BCDOUT_PTR) , 
2 LEN FIXED BINARY (7), 
2 VAL FIXED DECIMAL (P,Q); 
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BCDINP_PTR = ADDR(KEYVAL); /* overlay bed on string */ 
BCDINP.LEN = KEYLEN; /* set length byte 



of string */ 



BCDOUT_PTR = ADDR ( IDXVAL ) ; 
BCDOUT.LEN = KEYLEN; 



Whenever you use a numeric quantity with an Access Manager 
function, use KEYVAL for input values and IDXVAL for output values. 
To manipulate the key as a numeric quantity, refer to BCDINP.VAL and 
BCDOUT.VAL for input and output key values, respectively. For 
example, 

BCDINP.VAL = 123.45; 

DRN = SERKEY (KEY_NO,DFILE,DLOCK, KEYVAL, IDXVAL ) ; 
IF DRN ~= | DATVALO ~= THEN 
PUT SKIP LIST (BCDOUT.VAL); 



prints the numeric value of the first key value in the index greater 
than or equal to 123.45, unless no such key exists. 

3.4 Using the RECREATE. PLI Utility Program 

RECREATE. PLI contains the PL/I-80 source code for the RECREATE 
utility program. You can change the source code in whatever way you 
want. To create RECREATE.COM, compile RECREATE. PLI using PLI.COM 
and then link as follows: 

LINK RECREATE, AM80PLI . IRL [S , A] ,AM80BUF.IRL 

The buffer area for RECREATE is 4,600 bytes based on these 
parameter values: 

• NNSEC% = 4 

• NBUFS% = 8 

• NDATF% = 1 

• NKEYS% = 1 

Note that only one data file and one index file are open at the same 
time RECREATE is running. Use SETAMBUF to configure AM80BUF.IRL. 

Table 3-1 shows the layout and content of records in a Recreate 
Parameter File. This particular example file can be used to 
reconstruct DATABASE (see Listing 3-2) . 
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Table 3-1. Example PL/I-80 Recreate Parameter File 



Record Type 


Contents 


Header 


1,4 


Data File 


CUSTOMER . DAT ,100,3,0 


Index File 


N AME . I DX , 1 , , 1 , 1 , Y 


Key Part 


22,8 


Index File 


NUMB.IDX,4,0,0,1,N 


Key Part 


2,4 


Index File 


ZIPC.IDX,11,0,1,1,Y 


Key Part 


84,9 



If you want to change the capacities of the RECREATE program 
(and hence its memory requirements) , note the following key 
constants: 



• MAX_NO_KEYS specifies the maximum number of index files 
associated with a data file; MAX_KEY_PARTS indicates the 
maximum number of fields comprising a key value. 

• MAX_SORT is the maximum number of key values that can be 
buffered by RECREATE. PLI before being sorted and added to the 
index file being recreated. 

• MAX_SPACE specifies the actual number of bytes available for 
the buffered key values. Each key value requires one more byte 
than its key length. 

The actual number of buffered key values depends on the key 
length. For short key lengths, MAX_SORT will be the limiting 
factor. MAX_SPACE is the limiting factor for long key lengths. 

The constant MAX_REC_LEN should be increased if your 
applications require data files with record lengths exceeding 1024 
bytes. 

3.5 PL/I-80 Data File Example 

The following listing illustrates use of the primary Access 
Manager functions to update records in a data file: 
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EXAMPLE: 

PROC OPTIONS (MAIN) ; 

%REPLACE 

MAX KEY_LEN BY 48, 
NAME LEN BY 14; 



/* 

AM80 External Declarations 



V 

%INCLUDE 'AM80EXTR.PLI'; 



Exception Processing Routines 



V 
ERROR_HANDLER: 

PROC (LOCALE) ; 
DCL 

LOCALE FIXED; 

PUT SKIP EDIT ('ERROR at ', LOCALE,' with code ',ERRCOD()) 

(A,F(3) ,A,F(4)) ; 
STOP; 
END ERROR_HANDLER; 

LOCK_CONFLICT: 

PROC (LOCALE) 
DCL 

LOCALE FIXED; 

PUT SKIP EDIT ('LOCK Conflict at ', LOCALE,' with code ',ERRCOD()) 

(A,F(3) ,A,F(4)) ; 
STOP; 
END LOCK CONFLICT; 



Listing 3-1. PL/I-80 Data File Example 
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V 

DCL 



Variable Declarations 



(N_LOCK,S_LOCK,X_LOCK,S_FILE,X_FILE) FIXED, 
(NBUF, NKEYS, NNSEC, NDATF, ERROPT, PROGID, TIMOUT) FIXED, 
(DRN,DRN2,FILE_N0,REC0RD_LEN) FIXED, 
FILE_NAME CHAR (NAME LEN) VAR; 



1 DATJBUFFER 

2 PART_NO CHAR (4) 

2 PART_NAME CHAR (20) 

2 PART_QUAN FIXED DECIMAL (15,2), 
DATBUF PTR POINTER; 



Lock Parameter Setup 



V 












N LOCK 


= 





/* 


No lock request 


V 


S LOCK 


= 


1 


/* 


Shared record lock 


V 


X LOCK 


= 


2 


/* 


Exclusive record lock 


*/ 


S FILE 


= 


3 


/* 


Shared file lock 


V 


X FILE 


= 


4 


/* 


Exclusive file lock 


V 



System Initialization Parameters 



NBUF = 3; 


/ 


NKEYS = 1; 


/ 


NNSEC = 4; 


/ 


NDATF = 1; 


/ 


ERROPT = 1; 


/ 


PROGID = -1; 


/ 


TIMOUT = 3; 


/ 



3 buffers */ 

1 index file */ 

512-byte index file record length */ 

1 data file */ 

Trap user errors */ 

Program ID assigned to MP/M console no. */ 

Background server time-out delay */ 



Initialize System 



V 

PROGID = INTUSR (PROGID, ERROPT, TIMOUT) ; 

IF ERRCOD () ~= THEN 

CALL ERROR_HANDLER(l) ; 
IF SETUP (NBUF, NKEYS, NNSEC, NDATF) ~= THEN 

CALL ERROR HANDLER (2); 



Listing 3-1. (continued) 
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Open Files 



*/ 

FILE_NO = -1 /* Automatic file number assignment */ 

RECORD_LEN = 32; 

FILE_NAME = 'K:PART.DAT ' ; 

FILE_NO = OPNDAT(FILE_NO,S_FILE,FILE_NAME,RECORD_LEN) ; 

IF ERRCOD () ~= THEN 

CALL ERROR_HANDLER(3) ; 
IF LOKCOD () ~= THEN 

CALL LOCK_CONFLICT(3) ; 

/* 

Initialize Data Buffer Pointer 



*/ 

DATBUF PTR = ADDR(DAT BUFFER); 



Set Exclusive Lock on Data Record No. 65686 

V 

DRN2 = 1; 

CALL SETDAT(DRN2) ; /* Set two high-order bytes to 1, 

which implies a base of 65536 */ 
DRN = 150; /* 65686 = 65536 + 150 */ 

IF SETLOK(FILE_NO,DRN,DATBUF_PTR) ~= THEN 
CALL LOCK_CONFLICT(4) ; 

/* _ 

Read Data Record 

*/ 

CALL SETDAT(DRN2) ; 

IF READAT(FILE_NO,DRN,DATBUF_PTR ~= THEN 
CALL ERROR_HANDLER(4) ; 

/* 

Update Data Record 

V 

PART_QUAN = PART QUAN - 100.00; 



Write Updated Data Record 

V 

CALL SETDAT(DRN2) ; 

IF WRTDAT(FILE_NO,DRN,DATBUF_PTR ~= THEN 
CALL ERROR HANDLER (5); 



Listing 3-1. (continued) 
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Release Record Lock 



V 

CALL SETDAT(DRN2) ; 

IF FRELOK(FILE_NO,X_LOCK,DRN) ~= THEN 
CALL L0CK_C0NFLICT(6) ; 

/* 

Close Data File and Release File Lock 

*/ 

IF CLSDAT (FILE_NO) ~= THEN 

CALL ERROR_HANDLER ( 7 ) ; 

IF FRELOK (FILE_NO,S_FILE,0) ~= THEN 

CALL L0CK_C0NFLICT(7) ; 

END EXAMPLE; 



Listing 3-1. (continued) 



3.6 PL/I-80 DATABASE Source Code 

Your Access Manager distribution disk contains sample code for 
building and maintaining a data base in PL/I-80. The code is 
designed so you can add or substitute your own key attributes as 
required. The sample code is on your distribution disk in a file 
called DATABASE. Note that DATABASE is comprised of three separate 
components : 

• DAT ABAS l.PLI, 

• DATABAS2.PL I, 

• DATABASE. DCL. 

DATABASE demonstrates the integration of Access Manager with 
PL/I-80 applications. It builds a name and address data base and 
provides facilities for examining, updating, and/or listing the 
information contained therein. You might also want to use routines 
from DATABASE directly in your application programs. 

[SINGLE] To create DATABASE.COM, compile DATABAS1.PLI and 
DATABAS2.PLI with PLI.COM and link as follows: 

LINK DATABASE =D AT ABAS 1 ,DATABAS2 , 

AM80PLI.IRL[S,A] ,AM80BUF.IRL 

[MULTI] In a multiuser environment, enter the Link statement 
as follows: 

LINK DATABASE=DATABAS1 ,DATABAS2 ,AMQ8PLI . IRL [OP ,A] 
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Note that Listing 3-2 of DATABASE might not include recent changes. 
You should always treat the copy on your distribution disk as the 
definitive version. 

DATABASE. DCL 
/*: t :::::: t ::::::::::: i : t : t ::: i ::::::::::::: t :::::::::: i :: t i t t : : 

DATABASE EXAMPLE DECLARATIONS VERSION 1.05 4/20/82 0913 

*/ 

% REPLACE 

MAX_KEY BY 2, 
MAX_FIELD BY 7, 
MAX_KEY_LEN BY 20, 
MAX_FLD_LEN BY 20, 
NAME_LEN BY 14, 
FLD_NAME_LEN BY 18, 
ACTION_LEN BY 4, 
NEW_MODE BY 1, 
OLD_MODE BY 2, 
YES BY 1, 
YESBIT BY ' l'B, 
NOBIT BY '0'B, 
NO BY 0; 



/* 

*/ 
DCL 



WORKING VARIABLES 



(KEY , TERMINAL ,TRAP_ERRORS ,TIME_OUT_TEST_DELAY ,NO_BUFFERS , 
NO_NODE_SECTORS ,NO_DATA_FILES , NO_KEYS , FILE_NO , 
RECORD_LENGTH) FIXED STATIC EXTERNAL, 
(SET_LENGTH,IDX_KEY, SPACE) CHAR(MAX_KEY_LEN) VAR STATIC EXTERNAL, 
(SYSLST,SYSCON) FILE, 

OLD_ACTION CHAR(ACTION_LEN) STATIC EXTERNAL, 
FILNAME CHAR (NAME LEN) VAR STATIC EXTERNAL; 



DATABASE FIELD & KEY DESCRIPTORS 



FLD_NAME(0:MAX_FIELD) CHAR (FLD_NAME_LEN) VAR STATIC EXTERNAL, 
FLD_LEN{0:MAX_FIELD) FIXED BINARY (7) STATIC EXTERNAL, 

(OLD_FLD,NEW_FLD) (0 :MAX_FIELD) CHAR (MAX_FLD_LEN) VAR STATIC EXTERNAL, 
NO_FIELDS FIXED STATIC EXTERNAL; 

IDX_NAME(0:MAX_KEY) CHAR (NAME_LEN) VAR STATIC EXTERNAL, 
KEY NAME(0:MAX KEY) CHAR(FLD NAME LEN) VAR STATIC EXTERNAL, 



Listing 3-2. DATABASE. BAS Source Code 
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(KEY_LEN,KEY_MAP,KEY_TYPE,KEY_NUM,KEY_DUP) (0:MAX_KEY) FIXED 

STATIC EXTERNAL, 
FOR_EVER BIT(l) STATIC EXTERNAL, 
(UNIQ KEY, NLOCK, SLOCK, XLOCK,SFILE,XFILE,RLOCK) FIXED STATIC EXTERNAL; 



DATABAS1.PL I 



DATABASE: 

PROC OPTIONS (MAIN) ; 



DATABASE EXAMPLE VERSION 1.05 4/20/82 1943 

v 

%INCLUDE ' DATABASE. DCL' ; 

/* 

INTERFACE TO AM80 (tm) 

AM80EXTR.PLI CONTAINS THE EXTERNAL DEFINITIONS OF THE AM-80 ROUTINES 
V 

%INCLUDE 'AM80EXTR.PLI'; 

DCL 

ENTDAT ENTRY (CHAR(3) , FIXED) RETURNS (CHAR (ACTION_LEN) ) ; 



/* 



SET-UP DATABASE FIELD & KEY DESCRIPTORS 



NO_FIELDS = MAX_FIELD + 1; 

FLD_NAME(0) = 'Customer Number' 

FLD_LEN(0) = 4; 

FLD_NAME(1) = 'First Name ' ; 

FLD_LEN(1) = 16; 

FLD_NAME(2) = 'Last Name * ; 

FLD_LEN(2) = 20; 

FLD_NAME(3) = 'Street Address' ; 

FLD_LEN(3) = 20; 

FLD_NAME(4) = 'City'; 

FLD_LEN(4) = 20; 

FLD_NAME(5) = 'State'; 

FLD LEN(5) = 2; 



Listing 3-2. (continued) 
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FLD_NAME ( 6 ) = ' Z ipcode ' ; 
FLD_LEN(6) = 9; 

FLD_NAME(7) = 'Customer Status' 
PLD LEN(7) = 8; 



DCL 



DATBUF_PTR POINTER 
1 CUST_REC, 

2 CDF CHAR 

2 

2 

2 



CNO CHAR 
CFN CHAR 
CLN CHAR 
CST CHAR 
CTY CHAR 
CSA CHAR 
CZP CHAR 
CSU CHAR 



(1), 

(4), 

(16), 

(20), 

(20), 

(20), 

(2), 

(9), 

(8); 



KEY_LEN(0)=10 
KEY TYPE(0)=0 



KEY MAP(0)=2 


/* 


KEY 


= LAST NAME 


*/ 


KEY LEN(1)=11 










KEY TYPE(1)=0 










KEY MAP(1)=6 


/* 


KEY 


1 = Z IPCODE 


*/ 


KEY LEN(2)=4 










KEY TYPE (2) =0 










KEY_MAP(2)=0 


/* 


KEY 


2 = CUST NUMBER 


*/ 


UNIQJKEY = 2 


/* 


USED 


IN TEST OF UNIQUENESS 


V 



DO KEY = TO MAX_KEY; 

IF KEY = UNIQJKEY THEN 

KEY_DUP(KEY) = NO? 
ELSE 

KEY DUP(KEY) = YES; 



END; 



KEY NAME (KEY) = FLD NAME (KEY MAP(KEY)); 



IDXNAME(O) 
IDX_NAME(1) 
IDX NAME (2) 



•NAME.IDX'; 
•ZIPC.IDX'; 
'NUMB. IDX'; 



NLOCK =0; /* IGNORE LOCKS 

SLOCK =1; /* SHARED RECORD LOCK 

XLOCK =2; /* EXCLUSIVE RECORD LOCK 

SFILE =3; /* SHARED FILE LOCK 

XFILE =4; /* EXCLUSIVE FILE LOCK 

RLOCK =5; /* RELEASE SLOCK OR XLOCK 



Listing 3-2. (continued) 
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/* 
*/ 



INITIALIZE INDEX FILES 



SET_LENGTH = '12345678901'; 
IDXJKEY = SET_LENGTH; 
SPACE ' ' ; 

SET TERMINAL TO -1 FOR AUTOMATIC ASSIGNMENT BY AM-80 

TERMINAL = -1; 

TRAP_ERRORS = YES; 

TIME_OUT_TEST_DELAY = 2; /* APPROXIMATELY 2 SECONDS */ 

TERMINAL = INTUSR (TERMINAL , TRAPERRORS , TIME_OUT_TEST_DELAY ) ; 

IF ERRCODO ~= THEN 

CALL ERRORTYPE (0,14); 

NO_BUFFERS = 5; 
NO_NODE_SECTORS = 4; 
NO_DATA_FILES = 1; 
NO_KEYS = MAX_KEY + 1; 

IF SETUP (NO_BUFFERS,NO_KEYS,NO_NODE_SECTORS,NO_DATA_FILES) ~= THEN 
DO; 

PUT SKIP LIST ("Illegal SETUP Parameters'); 
STOP; 
END; 

DO KEY = TO MAX_KEY; 

KEYNUM(KEY) = OPNIDX (-1,IDX_NAME (KEY) , 

KEY_LEN ( KEY ) , KEY_TYPE ( KEY ) , KEYDUP ( KEY ) ) y 
IF ERRCODO ~= THEN 

CALL ERRORJTYPE ( KEY , 1 ) ; 
END; 



INITIALIZE DATA FILE 



FILE_NO = -1; 

RECORD_LENGTH = 100; 

FILNAME = 'CUSTOMER.DAT'; 

FILE_NO = OPNDAT(FILE_NO,SFILE, FILNAME, RECORD_LENGTH) 

IF ERRCODO ~= THEN 

CALL ERRORJTYPE (0,10); 
IF LOKCODO ~= THEN 

CALL LOKTYP(l) ; 



Listing 3-2. (continued) 
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/* 

*/ 



CUST_REC IS THE DATA FILE BUFFER AREA 
DATBUF PTR = ADDR(CUST REC) ; 



BEGIN DATABASE OPERATION 



OPEN FILE (SYSCON) OUTPUT TITLE (' $CON ') ; 
OPEN FILE (SYSLST) OUTPUT TITLE (' $LST' ) ; 

FOR_EVER = YESBIT; 
DO WHILE (FOR_EVER) ; 

CALL DATA_BASE ( ) ; 
END; 



DATA_BASE : 

PROC ; 



*/ 
DB(1) 



(LOCK_CODE,NDRN,DRN, CHOICE) FIXED, 
(SAVE_KEY,LDRN,NO_LISTED) FIXED, 
ROUTE CHAR(l) , 
(CONTINUE, STAYPUT) BIT(l), 

( L_VALUE , U_VALUE , CONV_TARGET , TARGET ) CHAR (MAX_KEY_LEN ) VAR , 
ACTION CHAR (ACTION LEN) ; 



CALL CLRSCR ( ) ; 
CHOICE = MAIN_MENU(); 
GOTO DB (CHOICE) ; 



ENTER NEW CUSTOMERS 



ACTION = ENTDAT ( ' NEW ' , ) ; 

LOCK_CODE = 0; 

IF ACTION = 'SAVE' THEN 

DO; 

NDRN = UPDATE (0) ; 

LOCK_CODE = FRELOK(FILE_NO,XLOCK,NDRN) 

END; 

IF LOCK_CODE ~= THEN 
CALL LOKTYP(8) ; 



Listing 3-2. (continued) 
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IF ACTION = 'SAVE' THEN 
GOTO DB(1) ; 

ELSE 

RETURN ; 



SCAN/UPDATE/DELETE CUSTOMERS 



V 
DB(2) 



KEY = SEARCH_KEY ( ) ; 

PUT SKIP (2) EDIT ('Enter target value for ' ,KEY_NAME (KEY) , ' 

' or enter a period (.) to see main menu>>') 

(3A,SKIP,A) ; 
GET LIST (TARGET) ; 
IF TARGET = '.' THEN RETURN; 

CONVJTARGET = KEY_FORMAT (KEY, TARGET ) ; 
STAYPUT = YESBIT; 
DO WHILE (STAYPUT) ; 

DRN = SURREY (KEY_NUM (KEY) ,FILE_NO, SLOCK, 

CONVJTARGET, I DX_KEY) ; 
IF ERRCODO ~= THEN 

CALL ERRORJTYPE ( KEY , 2 ) ; 
IF LOKCODO ~= THEN 

STAYPUT = CHECK_LOCK(KEY,DRN) ; 
ELSE 

STAYPUT =NOBIT; 
END; 

OLD_ACTION = 'CONT'; 
CONTINUE = YESBIT; 
DO WHILE (CONTINUE & DRN ~= 0) ; 
LDRN = DRN; 
CALL READ_CUST(DRN) ; 
ACTION = ENTDAT ( ' OLD ' , DRN ) ; 
SAVE_KEY = KEY; 
IF ACTION = 'SAVE' THEN 

DRN = UPDATE (DRN) ; 
IF ACTION = 'DELT' THEN 

CALL DELETE (DRN) ; 
IF ACTION ~= 'DELT' & FRELOK (FILE_NO,RLOCK,LDRN) ~= 

THEN CALL LOKTYP(2); 
IF ACTION = 'SAVE' ] ACTION = 'DELT' THEN 

DO; 

KEY = SAVE_KEY; 

ACTION = OLD_ACTION; 

END; 
OLD_ACTION = ACTION; 
CONV TARGET = SUBSTR(IDX KEY, 1, KEY LEN(KEY)); 



Listing 3-2. (continued) 



3-15 



Access Manager Programmer's Guide 3.6 DATABASE Source Code 



IDX_KEY = SET_LENGTH; 
LOCK_CODE = 0; 

STAYPUT = YESBIT; 
DO WHILE (STAYPUT) ; 

IP ACTION = 'CONT' THEN 
DO; 
DRN = AFTKEY(KEY_NUM(KEY) ,FILE_NO, 

SLOCK, CONV_TARGET,IDX_KEY) 
LOCKCODE = LOKCOD ( ) ; 
END; 
IF ACTION = 'BACK' THEN 
DO; 
DRN = BEFKEY(KEY_NUM(KEY) ,FILE_NO, 

SLOCK, CONV_TARGET,IDX_KEY) 
LOCKCODE = LOKCOD ( ) ; 
END; 

IF LOCK_CODE ~= THEN 

STAYPUT = CHECK_LOCK(KEY,DRN) ; 

ELSE 

STAYPUT = NOB IT; 
END; 

IF ACTION = 'STOP' THEN 

CONTINUE = NOBIT; 
END; 

PUT SKIP (2) LIST ('SCAN ENDED'); 
CALL PAUSE ( ) ; 
RETURN ; 



LIST CUSTOMERS 



V 

DB(3): 

KEY = SEARCH_KEY ( ) ; 

PUT SKIP (2) LIST ( 
'Do you want listing routed to printer (Y/N) >>'); 

GET LIST (ROUTE) ; 

IF ROUTE = 'y' THEN ROUTE = 'Y' ; 

PUT SKIP (3) EDIT ( 
•Enter lower and upper limits for ' ,KEY_NAME (KEY) , ' listing' 
' separate values with a space >>') (3A,SKIP,A) ; 

GET LIST (L_VALUE,U_VALUE) ; 

L_VALUE = KEY_FORMAT(KEY,L_VALUE) ; 

U_VALUE = KEY_FORMAT(KEY,U_VALUE) ; 

DRN = SERKEY (KEY_NUM (KEY ) ,FILE_NO, SLOCK, 
L VALUE, IDX KEY) ; 



Listing 3-2. (continued) 
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IF LOKCODO ~= THEN 

CALL SKIP_LOCK(KEY,DRN) ; 

NO_LISTED = 0; 

DO WHILE (DRN ~= & COMPARE (KEY, I DX_KEY,U_VALUE) <= 0) ; 
CALL READ_CUST(DRN) ; 
CALL PRINT_CUST (ROUTE) ; 
NO_LISTED = NO_LISTED + 1; 
IF FRELOK(FILE_NO, SLOCK, DRN) ~= THEN 

CALL LOKTYP(4) ; 
L_VALUE = SUBSTR ( I DX_KEY , 1 , KE Y_LEN ( KE Y ) ) ; 
IDX_KEY = SET_LENGTH; 
DRN = AFTKEY(KEY_NUM(KEY) ,FILE_NO, SLOCK, 

L_VALUE,IDX_KEY) ; 
IF LOKCODO ~= THEN 

CALL SKIP_LOCK (KEY ,DRN) ; 
END; 

IF DRN ~= THEN 

LOCK_CODE = FRELOK (FILE_NO, SLOCK, DRN) ; 
ELSE 

LOCK_CODE = 0; 
IF LOCK_CODE ~= THEN 

CALL LOKTYP(5) ; 

PUT SKIP (2) EDIT (NO_LISTED,' records listed.') (F(6),A); 

CALL PAUSE ( ) ; 

RETURN; 



DATABASE STATISTICS 



*/ 
DB(4) 



CALL CLRSCR ( ) ; 

PUT SKIP EDIT (FILNAME,' has ' ,GETDFS (FILE_NO) , 

' records; currently, ' ,GETDFU (FILE_NO) , 

' of them are in use.') (2A,F (6) ,A,F (6) ,A) ; 
PUT SKIP (4) EDIT (' INDEX' , 'ENTRIES ' ) (A, COLUMN (30) , A) ; 

PUT SKIP EDIT (' ',' ') (A, COLUMN ( 30 ), A); 

DO KEY = TO MAX_KEY; 

PUT SKIP EDIT (KEY_NAME(KEY) ,NOKEYS(KEY) ) (A, COLUMN (30) ,F (6) ) ; 
END; 

PUT SKIP (4) ; 
CALL PAUSE ( ) ; 
RETURN; 



Listing 3-2. (continued) 
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SAVE DATABASE UPDATES & RESTART 



DB(5): 



IF SAVDAT(FILEJJO) ~= THEN 

CALL ERRORJTYPE (0,7); 
DO KEY = TO MAXJCEY; 

IF SAVIDX(KEY_NOM(KEY)) ~= THEN 
CALL ERRORJTYPE ( KE Y , 3 ) ; 
END; 
RETURN; 



SAVE DATABASE UPDATES & TERMINATE 



V 

DB(6): 

CLOSE FILE (SYSLST) ; 

IF CLSDAT(FILE_NO) ~= THEN 

CALL ERRORJTYPE (0,15) ; 
DO KEY = TO MAX_KEY; 

IF CLSIDX(KEY_NUM(KEY) ) ~= THEN 
CALL ERRORJTYPE (KEY , 16 ) ; 
END; 
IF FRELOK(FILEJJO,SFILE,0) ~= THEN 

CALL ERRORJTYPE (0,13); 

PUT SKIP (2) LIST (' *** SUCCESSFUL TERMINATION ***') 
STOP; 
END DATA BASE; 



/* 

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 

BEGINNING OF UTILITY FUNCTIONS 



CLEAR SCREEN ROUTINE 

v "" 

CLRSCR: 

PROC EXTERNAL; 
DCL 



Listing 3-2. (continued) 
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DUMMY FIXED BINARY (7); 

DO DUMMY = 1 TO 24; 

PUT SKIP; 
END; 
END CLRSCR; 

/* 



MAIN MENU ROUTINE 



*/ 

MAIN_MENU: 

PROC RETURNS (FIXED) ; 
DCL 

OP FIXED; 

PUT SKIP EDIT (' AM-80(tm) DEMONSTRATION') (X(20),A); 

PUT SKIP(2) EDITC Customer Database Operations') (X(20),A); 

PUT SKIP EDIT(' Terminal ', TERMINAL) (X (20) ,A,F (2) ) ; 

PUT SKIP EDITC ****************************•) (X(20),A); 

PUT SKIP(3) EDITC1. Enter New Customers') (X(5),A); 

PUT SKIP EDITC 2. Scan/Update/Delete Customer Records') (X(5),A) 

PUT SKIP EDITC 3. List Customer Records') (X(5),A); 

PUT SKIP EDITC 4. Database Statistics') (X(5),A); 

PUT SKIP EDIT ('5. Save All Files & Restart Operations') (X(5),A) 

PUT SKIP EDIT('6. Terminate Operations') (X(5),A); 

OP = 0; 

DO WHILE (OP < 1 | OP > 6); 

PUT SKIP (2) LIST ('Enter desired operation number>>'); 

GET LIST (OP) ; 
END; 

RETURN (OP) ; 
END MAIN_MENU; 

/* 

SELECT SEARCH KEY ROUTINE 

*/ 

SEARCH_KEY: 

PROC RETURNS (FIXED) ; 
DCL 

(KEY,KEY_NO) FIXED; 

CALL CLRSCR ( ) ; 

PUT EDIT ('Customer Database Search Keys') (X(25) f A); 

PUT SKIP (3) ; 



Listing 3-2. (continued) 
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DO KEY = TO MAX_KEY; 

KEY_NO = KEY + 1; 

PUT SKIP EDIT (KEY_NO,' - ' , KE Y_NAME ( KE Y ) ) (X (5) ,F (3) ,2A) 
END; 

KEY = 0; 

DO WHILE (KEY < 1 | KEY > NO_KEYS) ; 

PUT SKIP (3) LIST ('Enter desired key number>>'); 

GET LIST (KEY) ; 
END; 

RETURN ( KEY- 1) ; 
END SEARCHKEY; 

/* 

ERROR HANDLING 



EREOR_TYPE : 

PROC (INFO, TYPE) ; 
DCL 

(T_KEY, INFO, DUMMY, TYPE) FIXED; 

PUT SKIP(3) EDIT ('User Error # ' ,ERRCOD () , ' occurred while trying to ') 
(A,F(4) ,A) ; 

GOTO ET(TYPE) ; 

ET(1): PUT EDIT ('open ' ,IDX_NAME (INFO) ) (2A) ; 

GOTO ET_STOP; 
ET(2): PUT EDIT ('search ' ,KEY_NAME (INFO) , * Index File') (3A) ; 

GOTO ET_CLOSE; 
ET(3): PUT EDIT ('save ' ,IDX_NAME (INFO) ) (2A) ; 

GOTO ETJPCLOSE; 
ET(4): PUT EDIT (' remove old key from ' ,IDX_NAME (INFO) ) (2A) ; 

GOTO - ET_CLOSE; 
ET(5): PUT EDIT ('enter key into * ,IDX_NAME (INFO) ) (2A) ; 

GOTO ET_CLOSE; 
ET(6): PUT EDITCdelete key from ' ,IDX_NAME (INFO) ) (2A) ; 

GOTO ET_CLOSE; 
ET(7): PUT EDIT ('save ' ,FILNAME) (2A); 

INFO = -1; 

GOTO ET_PCLOSE; 
ET(8): PUT EDIT('get a new data record',' ( ' ,FILE_NO, ' ) ' ) (2A,F(3),A); 

GOTO ET_STOP; 
ET(9): PUT EDITCdelete data record #',INFO) (A,F(6)); 

GOTO ET_STOP; 
ET(10): PUT EDIT ('open ' ,FILNAME, ' ( ' ,FILE_NO, ' ) ' ) (2A,F(3),A); 

GOTO ET_STOP; 
ET(ll): PUT EDIT ('read data record #',INFO) (A,F(6)); 

GOTO ET STOP; 



Listing 3-2. (continued) 
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ET(12): PUT EDIT('wcite data record #',INFO) (A,F(6)); 

GOTO ET_STOP; 
ET(13): PUT EDIT (' release shared file lock on ' ,FILNAME) (2A) ; 

GOTO ETJ3T0P; 
ET(14): PUT EDIT (' initialize user.') (A); 

STOP; 
ET(15): PUT EDIT ('close ' ,FILNAME) (2A) ; 

INFO = -1; 

GOTO ET_PCLOSE; 
ET(16): PUT EDIT ('Close ' ,IDX_NAME (INFO) ) (2A) ; 

GOTO ETPCLOSE; 

ET_CLOSE : 

DUMMY = CLSDAT(FILE_NO) ; 
DO T_KEY = TO MAX_KEY; 

IF T_KEY ~= INFO THEN DUMMY = CLSIDX (KEY_NUM (T_KEY) ) ; 
END; 
GOTO ET_STOP; 

ET_PCLOSE : 

TJKEY = INFO + 1; 

IF T_KEY>MAX_KEY THEN STOP; 

DO INFO = T_KEY TO MAX_KEY; 

DUMMY = CLSIDX(KEY_NUM(INFO)) ; 
END; 

ET_STOP : 

PUT SKIP (2) EDIT ('DEMONSTRATION TERMINATING WITH ERROR CODE #' 

ERRCODO) (A,F(4)); 
STOP; 

END ERRORJTYPE; 

LOKTYP : 

PROC (TYPE) EXTERNAL; 
DCL 

(T_KEY, DUMMY, TYPE) FIXED; 

PUT SKIP EDIT ('Lock Type: ' ,TYPE, ' Lock Code: ' ,LOKCOD () ) 

(A,F(3) ,A,F(3)) ; 
DUMMY = CLSDAT (FILE_NO) ; 
DO T_KEY = TO MAX_KEY; 

DUMMY = CLSIDX (KEY_NUM (T_KEY) ) ; 
END; 
STOP; 
END LOKTYP; 

/* 

STRIP TRAILING BLANKS 
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STRIPJ3LANKS: 

PROC (OLD_VAL) RETURNS (CHAR (MAX_FLD_LEN) VAR) ; 
DCL 

OLD_VAL CHAR(MAX_FLD_LEN) , 
(TEST, FLDLEN) FIXED; 

FLDLEN = LENGTH (OLD_VAL) ; 
DO TEST = FLDLEN TO 1 BY -1; 

IF SUBSTR(OLD_VAL,TEST,l) ~= ' ' THEN 

RETURN ( SUBSTR ( OLDVAL , 1 , TEST ) ) 
END; 

RETURN ( ' ' ) ; 
END STRIP_BLANKS; 

/* 



READ DATA RECORD ROUTINE 



V 

READ_CUST: 

PROC (DRN) ; 
DCL 

DRN FIXED; 



I F READAT ( F I LENO , DRN , DATBUF_PTR ) 
CALL ERROR TYPE (DRN, 11) ; 



OLD_FLD(0) = STRIP_BLANKS (CNO) 
OLDFLD(l) = STRIP_BLANKS(CFN) 
OLD_FLD(2) = STRIP_BLANKS(CLN) 
0LD_FLD(3) = STRIPBLANKS (CST) 
OLD_FLD(4) = STRIP_BLANKS(CTY) 
OLD_FLD(5) = STRIP_BLANKS (CSA) 
OLD_FLD(6) = STRIP_BLANKS(CZP) 
OLD FLD(7) = STRIP BLANKS (CSU) 



END READ_CUST; 
/* 



LIST CUSTOMER RECORD ROUTINE 



V 



PRINT_CUST: 

PROC (ROUTE) ; 
DCL 

ROUTE CHAR(l) , 

LIST_FILE FILE VARIABLE; 

LFRMT: 
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FORMAT (X( 24) ,5A) ; 

IF ROUTE = 'Y' THEN 

LIST_FILE = SYSLST; 
ELSE 

LIST_FILE = SYSCON; 

PUT FILE (LIST_FILE) SKIP (2) EDIT (OLD_FLD (0) ,OLD_FLD (7) ) 

(X(4) ,A,COLUMN(15) ,A) ; 

PUT FILE (LIST_FILE) EDIT (OLD_FLD (1) , ' ' , OLD_FLD ( 2 ) ) (R(LFRMT)); 

PUT FILE (LIST_FILE) EDIT (OLD_FLD (3 ) ) (R(LFRMT)); 

PUT FILE (LIST_FILE) EDIT (OLD_FLD (4 ) , * , ■ ,OLD_FLD (5) , ' ' , OLD_FLD ( 6 ) ) 

(R(LFRMT)) ; 

PUT FILE(LIST_FILE) SKIP; 
END PRINT_CUST; 

/* 

PAUSE ROUTINE 



*/ 
PAUSE : 
DCL 



PROC; 

DUMMY CHAR(l) ; 



PUT SKIP (2) LIST ('Enter any character to continue '); 

GET LIST (DUMMY) ; 
END PAUSE; 

/* 



CONVERT TARGET VALUE TO KEY FORMAT ROUTINE 



KEY_FORMAT: 

PROC (KEY, TARGET) RETURNS (CHAR(MAX_KEY_LEN) VAR) ; 
DCL 

KEY FIXED, 

TEMP CHAR (40) VAR, 

TARGET CHAR(MAX_KEY_LEN) VAR; 

IF UNIQ_KEY = KEY THEN 

RETURN (TARGET) ; 
ELSE 

DO; 

TEMP = TARGET | | SPACE; 

RETURN ( SUBSTR ( TEMP , 1 , KEY_LEN ( KEY ) - 2 ) | | 
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ASCII(O) | | ASCII(O)); 
END; 
END KEY_FORMAT; 

/* 

COMPARE IDX_KEY & U_VALUE ROUTINE 

*/ 

COMPARE : 

PROC (KEY,IDXVAL,UPVAL) RETURNS (FIXED); 
DCL 

(KL,KEY) FIXED, 

(C1,C2) CHAR (40) VAR, 

(IDXVAL,UPVAL) CHAR(MAX_KEY_LEN) VAR; 

IF KEY = UNIQ_KEY THEN 

KL = KEY_LEN(KEY) ; 
ELSE 

KL = KEY_LEN(KEY)-2; 

Cl = IDXVAL | | SPACE; 
Cl = SUBSTR(C1,1,KL) ; 
C2 = UPVAL | | SPACE; 
C2 = SUBSTR(C2,1,KL) ; 

IF CKC2 THEN 

RETURN (-1) ; 
ELSE IF C1>C2 THEN 

RETURN (1) ; 



ELSE 
END COMPARE; 
/* 



RETURN ( ) ; 



CHECK LOCK ROUTINES 



SKIP_LOCK: 

PROC (KEY, DRN); 
DCL 

L_VALUE CHAR(MAX_KEY_LEN) VAR, 

(KEY,DRN) FIXED; 

DO WHILE (DRN ~= & LOKCODO ~= 0); 

L_VALUE = SUBSTR(IDX_KEY,1,KEY_LEN(KEY) ) 

IDX_KEY = SET_LENGTH; 

DRN = AFTKEY(KEY NUM(KEY) ,FILE NO, SLOCK, 
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L_VALUE , IDX_KEY) ; 
END; 
END SKIP_LOCK; 

CHECKLOCK: 

PROC (KEY, DRN) RETURNS (BIT(l)); 
DCL 

CONVJTARGET CHAR(MAX_KEY_LEN) VAR, 

(KEY,DRN) FIXED, 

DUMMY CHAR(l) ; 

PUT SKIP (2) LIST( 
'Enter a "W" if you want to wait for locked record (s) >>') ; 
GET LIST (DUMMY)'; 

IF DUMMY = 'W | DUMMY = 'w' THEN 
RETURN (YESBIT) ; 

DO WHILE (DRN "= & LOKCOD ( ) "= ) ; 

CONVJTARGET = SUBSTR ( IDX_KEY , 1 , KEY_LEN ( KEY ) ) ; 

IDX_KEY = SETJLENGTH; 

IF OLD_ACTION = 'CONT' THEN 

DRN = AFTKEY(KEY_NUM(KEY) ,FILE_NO, 

SLOCK , CONVJTARGET , IDX_KEY ) ; 
ELSE 

DRN = BEFKEY(KEY_NUM(KEY) ,FILE_NO, 

SLOCK , CONVJTARGET , IDX_KEY ) ; 
END; 

RETURN (NOBIT) ; 
END CHECK_LOCK; 

/* 

WARNING MESSAGES 



WARNING_TYPE: 

PROC ( KEY , TYPE , RET_CODE ) ; 
DCL 

(KEY, TYPE, RET_CODE) FIXED; 

PUT SKIP(2) EDIT ('WARNING. ..Return Code #',RET_CODE, 

' occurred while trying to ') (A,F(3),A); 
GOTO WT(TYPE) ; 

WT(1): PUT EDIT ('remove old key from ' ,IDX_NAME (KEY) ) (2A) ; 
CALL PAUSE ( ) ; 
RETURN; 

WT(2): PUT EDIT ('enter key into ' ,IDX_NAME (KEY) ) (2A) ; 
CALL PAUSE ( ) ; 
RETURN; 
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WT(3): PUT EDIT ('delete key from ' ,IDX_NAME(KEY) ) (2A): 
CALL PAUSE ( ) ; 
RETURN; 

END WARNING_TYPE; 
/* 

ADD NEW KEY VALUE ROUTINE 



*/ 
ADD_KEY: 
DCL 

/* 
*/ 



PROC (KEY,DRN); 

(KEY,RET_CODE,K_FLD,DRN) FIXED; 
K_FLD = KEY_MAP(KEY) ; 

REMOVE OLD KEY VALUE 



/* 
V 



RET_CODE = DELKEY(KEY_NUM(KEY) ,FILE_NO, 
XLOCK,OLD_FLD(K_FLD) ,DRN) ; 

IF ERRCODO ~= THEN 

CALL ERROR_TYPE ( KEY , 4 ) ; 

IF LOKCODO ~= THEN 

CALL LOKTYP(6) ; 

IF RET_CODE ~= 1 THEN 

CALL WARNING TYPE (KEY, 1, RET CODE) 



ADD NEW KEY VALUE 



RET_CODE = ADDKEY(KEY_NUM(KEY) ,FILE_NO, 
XLOCK,NEW_FLD(K_FLD) ,DRN) ; 

IF ERRCODO ~= THEN 

CALL ERRORJTYPE ( KEY , 5 ) ; 

IF LOKCODO ~= THEN 

CALL LOKTYP(7) ; 

IF RET_CODE ~= 1 THEN 

CALL WARNING TYPE (KEY, 2 , RET CODE) 



END ADD_KEY; 
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WRITE NEW DATA RECORD ROUTINE 



WRITE 


COST: 






PROC 


(DRN) ; 


DCL 








DRN 


FIXED; 




CDF 


= ASCII (0) ; 




CNO 


= NEW FLD(O) 




CFN 


= NEW FLD(l) 




CLN 


= NEW FLD(2) 




CST 


= NEW FLD(3) 




CTY 


= NEW FLD(4) 




CSA 


= NEW FLD(5) 




CZP 


= NEW FLD(6) 




CSU 


= NEW FLD(7) 



/* CLEAR DELETE FLAG */ 



IF WRTDAT (FILE_NO,DRN,DATBUF_PTR) 
CALL ERROR_TYPE(DRN,12) ; 
END WRITE CUST; 



/* 



DELETE KEY VALUE FROM INDEX ROUTINE 



V 
DEL KEY: 



PROC (KEY, DRN); 

( KEY , RET_CODE , K_FLD , DRN ) ; 

K_FLD = KEY_MAP(KEY) ; 

RET_CODE = DELKEY(KEY_NUM(KEY) ,FILE_NO, 
XLOCK,OLD_FLD(K_FLD) ,DRN) ; 

IF ERRCOD() ~= THEN 

CALL ERRORJTYPE ( KEY , 6 ) ; 
IF LOKCOD() ~= THEN 

CALL LOKTYP ( 10 ) ; 
IF RET_CODE ~= 1 THEN 

CALL WARNING_TYPE(KEY,3,RET CODE); 



END DEL_KEY; 
/* 



UPDATE INDICES & DATA FILE ROUTINE 
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*/ 

UPDATE : 
DCL 



PROC (DATA_RECORD) RETURNS (FIXED) ; 

(FLD,KEY) FIXED, 

( TMP_REC , DATA_RECORD ) FIXED; 

IF DATA_RECORD = THEN 
DO; 

TMP_REC = NEWREC(FILE_NO,XLOCK) ; 
IF ERRCODO ~= THEN 

CALL ERRORJTYPE (0,8); 
IF LOKCODO ~= THEN 

CALL LOKTYP(3) ; 
END; 



ELSE 



TMP REC = DATA RECORD; 



DO KEY = TO MAX_KEY; 

FLD = KEY_MAP(KEY) ; 

IF OLDFLD(FLD) ~= NEW_FLD(FLD) THEN 
CALL ADD_KEY ( KEY , TMPREC ) ; 
END; 

DO FLD = TO MAX_FIELD; 

IF OLDFLD(FLD) "= NEW_FLD(FLD) THEN 

DO; 

CALL WRITE_CUST (TMPREC); 

RETURN (TMP_REC) ; 

END; 
END; 

RETURN (TMP_REC) ; 
END UPDATE; 



DELETE INDEX & DATA FILE ENTRY ROUTINE 



*/ 

DELETE : 

PROC (DATA_RECORD) ; 
DCL 

(DATA_RECORD,FLD,KEY) FIXED; 

DO KEY = TO MAXJKEY; 

FLD = KEY_MAP(KEY) ; 

IF OLD_FLD(FLD) ~= " THEN 

CALL DEL_KEY ( KEY , DAT ARECORD ) ; 
END; 



Listing 3-2. (continued) 



3-28 



Access Manager Programmer's Guide 3.6 DATABASE Source Code 



IF RETREC(FILE_NO,XLOCK,DATA_RECORD) ~= THEN 

CALL ERROR_TYPE (DATA_RECORD , 9 ) ; 
IF LOKCODO ~= 0. THEN 

CALL LOKTYP(9) ; 
END DELETE; 

/* 

END OF UTILITY FUNCTIONS 

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
*/ 

END; 



DAT ABAS 2. PL I 



ENTDAT: 



PROC (ENTER MODE, DRN) RETURNS (CHAR (4)) EXTERNAL; 



DATA ENTRY ROUTINE 



DCL 

UNIQUE BIT(l) , 

(DRN,FLD,OP_VAL,FLD_NO) FIXED, 
OP CHAR (2) VAR, 
OP1 CHAR(l) , 
TEMP_MODE FIXED, 
ENTER_MODE CHAR ( 3 ) ; 

% INCLUDE " DATABASE . DCL ' ; 
%INCLUDE 'AM80EXTR.PLI 1 ; 



CLRSCR ENTRY, 

LOKTYP ENTRY (FIXED) ; 

IF ENTER_MODE = 'NEW' THEN 

DO FLD = TO MAX_FIELD; 
OLD_FLD(FLD) = ' 
END; 

IF ENTER_MODE = 'OLD' THEN 

DO FLD = TO MAX FIELD; 
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NEW_FLD(FLD) = OLD_FLD ( FLD ) ; 
END; 

CALL CLRSCRO ; 

IF ENTER_MODE = 'NEW THEN 
DO; 

POT SKIP EDIT ('Enter New Customer Information') (X(19),A); 
PUT SKIP EDIT ('******************************') (X(19),A); 
PUT SKIP (3) LIST ( 

' [Enter zero for customer # to see main menu.]'); 
PUT SKIP (2) ; 



REDO DATA: 



DO FLD = TO MAX_FIELD; 
FLD_NO = FLD + 1; 

PUT EDIT (FLD_NO,' - ' ,FLD_NAME (FLD) , 
' (' ,FLD_LEN(FLD) ,') »') 
(F(6) ,2A,COLUMN(30) ,A,F(2) ,A) ; 

GET LIST (NEW_FLD(FLD)) ; 

IF FLD = KEY_MAP(UNIQ_KEY) & NEW_FLD(FLD) = '0' THEN 
RETURN ( ' STOP ' ) ; 

IF FLD = KEY_MAP(UNIQ_KEY) THEN 
DO; 
NEW_FLD(FLD) = RIGHT ('0000' || NEW_FLD (FLD) , 

FLD_LEN(FLD)) ; 
UNIQUE = TEST_UNIQUENESS ( ) ; 
END; 
ELSE 

DO; 

NEW_FLD(FLD) = SUBSTR (NEW_FLD (FLD) , 1, 

FLD_LEN(FLD)) ; 
UNIQUE = YESBIT; 
END; 

IF "UNIQUE THEN GOTO REDO_DATA; 
END; 

TEMP_MODE = NEW_MODE; 
END; 
ELSE 

TEMP_MODE = OLD_MODE; 

DO WHILE (FOR_EVER) ; 

PUT SKIP (4) EDIT ('Current customer information') 

(X(19),A); 
PUT SKIP; 

DO FLD = TO MAX_FIELD; 

FLD_NO = FLD +1; 

PUT SKIP EDIT (FLD_NO,' - ' ,FLD_NAME (FLD) ,NEW_FLD (FLD) ) 
(F ( 6 ) , 2A , COLUMN ( 30 ) , A) ; 
END; 

IF TEMP MODE = OLD MODE THEN 
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BEGIN; 
OP_VAL = 0; 
ON ERROR (1) 

BEGIN; 
OP_VAL = 0; 
GOTO RETRY_OLD; 
END; 
RETRY_OLD: 

DO WHILE (OP_VAL < 1 | OP_VAL > NO_FIELDS) ; 
PUT SKIP (3) EDIT ( 
'Enter C to continue scan. Field # to change data, S to save changes , * , 
'D to delete data, B for back scan, or E to end scan >>') (A, SKIP, A) ; 

GET LIST (OP) ; 
0P1 = OP; 



' C ' THEN RETURN ( • CONT ' ) 
's' THEN 



1 BACK ' ) i 
STOP ' ) ; 



IF OP1 = 'C OP1 
IF OP1 = 'S* I 0P1 

RETURN (SET_XL0CK (OP1 , DRN ) ) ; 
IF OP1 = 'D' | OP1 = 'd' THEN 

RETURN (SET_XLOCK (OPl,DRN) ) ; 
IF OP1 = 'B' I OP1 = 'b' THEN RETURN) 
IF OP1 = 'E' I OP1 = 'e' THEN RETURN ( 
OP_VAL = OP; 
END; 

CALL UPDATE_FIELD(OP_VAL) ; 
END; 
ELSE 

BEGIN; 
OPVAL = 0; 
ON ERROR (1) 

BEGIN; 
OP_VAL = 0; 
GOTO RETRY_NEW; 
END; 
RETRY_NEW: 

DO WHILE (OP_VAL < 1 | OP_VAL > NO_FIELDS) ; 
PUT SKIP (3) EDIT ( 
'Enter S to save data, Field # to change data,', 
'D to delete data, or E to end input >>') (A, SKIP, A) ; 

GET LIST (OP) ; 
OP1 = OP; 



•S" 
■D" 



OP; 



IF OP1 

IF OP1 = 

IF OP1 = 

OP_VAL = 
END; 

CALL UPDATE_FIELD(OP_VAL) ; 
END; 



OP1 = 's' THEN RETURN (' SAVE ' ) 
OP1 = 'd' THEN RETURN (' DELT ' ) 
OP1 = 'e' THEN RETURN (' STOP ' ) 



END; 



SET_XLOCK: 

PROC (OP, DRN) RETURNS (CHAR (ACTION_LEN) ) ; 
DCL- 

DRN FIXED, 

(DUMMY, OP) CHAR(l); 
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DUMMY = 'W'; 

DO WHILE (DUMMY = 'W' & SETL0K(FILE_NO,XL0CK,DRN) ~= 0); 
PUT SKIP (2) EDIT ( 
'Customer update on hold due to record lock', 

'Enter W if you want to wait or any other key to cancel update>>') 
(A, SKIP, A) ; 

GET LIST (DUMMY) ; 

IF DUMMY = 'w' THEN DUMMY = 'W ; 
END; 

IF DUMMY = 'W THEN 
DO; 
IF OP = 'S' THEN 

RETURN ( ' SAVE ' ) ; 
ELSE 

RETURN('DELT') ; 
END; 



ELSE 
END SET XLOCK; 



RETURN (OLD ACTION); 



/* 



UPDATE DATA FIELD ROUTINE 



UPDATE_FIELD: 

PROC (FLD_NO) ; 



TEST BIT(l) , 
(FLD_NO,FIELD_NO) FIXED; 

FIELD_NO = FLD_NO-l; 
TEST = NOB IT; 

DO WHILE ("TEST) ; 

PUT SKIP(2) EDIT ('Input new ' ,FLD_NAME (FIELD_NO) , ' >> ' ) 

(3A); 
GET LIST (NEW_FLD(FIELD_NO) ); 

IF FIELD_NO = KEY_MAP(UNIQ_KEY) THEN 

NEW_FLD(FIELD_NO) = RIGHT ('000Q' || NEW_FLD (FIELD_NO) 
FLD_LEN (FIELD_NO) ) ; 
ELSE 

NEW_FLD(FIELD_NO) = SUBSTR(NEW_FLD (FIELD_NO) , 1, 
FLD_LEN(FIELD_NO) ) ; 

IF FIELD_NO = KEY_MAP(UNIQ_KEY) & NEW_FLD ( F I ELD_NO ) ~= 
OLD_FLD (FIELD_N0) THEN 

TEST = TEST UNIQUENESS () ; 
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TEST = YESBIT; 
END; 
END UPDATE FIELD; 



CUST # UNIQUENESS TEST ROUTINE 



TEST_UNIQUENESS : 

PROC RETURNS (BIT(l)); 
DCL 

TEMP FIXED, 

TEST CHAR(MAX_FLD_LEN) VAR; 

TEST = NEW_FLD(KEY_MAP(UNIQ_KEY)) ; 
TEMP = GETKEY(UNIQ_KEY,0,NLOCK,TEST) ; 

IF LOKCODO ~= THEN 

CALL LOKTYP(12) ; 
IF TEMP = THEN 

RETURN (YESBIT) ; 
ELSE 

DO; 

PUT SKIP (2) LIST (' *** Already Assigned ***') 

PUT SKIP; 

RETURN (NOBIT) ; 

END; 
END TEST UNIQUENESS; 



RIGHT STRING ROUTINE 



*/ 
RIGHT: 
DCL 



PROC (FLDSTR,FLDLEN) RETURNS (CHAR (MAX_FLD_LEN) VAR); 

FLDLEN FIXED, 

FLDSTR CHAR (MAX FLD LEN) VAR; 



RETURN (SUBSTR (FLDSTR, LENGTH (FLDSTR) -FLDLEN+1) ) ; 
END RIGHT; 

END ENTDAT; 
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Using Access Manager with PascaI/MT+ Applications 



This section contains instructions for implementing Access 
Manager with application programs coded in Pascal/MT+. 

Two examples are provided. The first illustrates the use of 
many Access Manager functions described in your Reference Manual, 
and in particular, how to use the data file functions in your 
Pascal/MT+ applications. The second example illustrates the use of 
Access Manager to create and maintain a data base. 

4.1 Linking Access Manager to Your Application Program 

This section discusses a Pascal/MT+ application program called 
MYPROG that you write and compile to produce a binary relocatable 
file. 



4.1.1 Linking Single-user Pascal/MT+ Applications 

You must link your compiled application program to the 
appropriate Access Manager subroutine library and index file buffer 
module. You can use the following command line to create an 
executable version of MYPROG: 

LINKMT MYPROG, AM80PASC/S ,AM80BUF,PASLIB/S 

AM80BUF contains the buffer area beginning with entry point AM8FCB 
and ending with AM8END. 

Before linking, be sure AM80BUF.ERL is large enough to contain 
your buffers (as specified in the SETUP function) . You can use 
SETAMBUF to create a correctly sized buffer module. 

If LINKMT.COM returns an out-of-memory message, you must modify 
the link statement so the data segment is explicitly placed after 
the code segment. The /D switch of LINKMT does this modification. 
To determine the appropriate origin for the data segment, perform a 
trial link in which the data segment origin is very high. For 
example, 

LINKMT MYPROG, AM80PASC/S , AM80BUF,PASLIB/S/D: CO 00 

Then, based on the size of the code segment returned by LINKMT, 
you can reset the origin of the data segment to a value somewhat 
above the code segment and perform the final link. For more 
details, see the example link statements for DATABASE. SRC and 
RECREATE. SRC later in this section. 
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4.1.2 Linking Multiuser Pascal/MT-t- Applications 

If your single-user version of MYPROG is coded with appropriate 
data locking procedures, you do not have to recompile it to create a 
multiuser version. All that is necessary is to relink the program. 

You must link your compiled application program to the 
appropriate Access Manager multiuser interface. The interface makes 
the queue calls to the shared code in the background server. The 
background server resides in its own memory segment. 

To create a COM file that calls the Access Manager background 
server, use LINKMT.COM as follows: 

LINKMT MYPROG, AMQ8PASCPASLIB/S 



4.2 External Declaration of Access Manager Routines 

Pascal/MT+ requires that external routines (those not coded in 
the program module but referenced by it) be explicitly declared. 
The file AM80EXTR.PSC contains external function declarations for 
the entire set of Access Manager routines. Use the Include File 
compiler toggle of Pascal/MT+ to make these external declarations a 
part of your application program. For example, 

{$1 AM80EXTR.PSC} 
includes the external declarations as required. 

All Access Manager string-valued parameters (FILNAME, IDXNAME, 
KEYVAL, and IDXVAL) must be declared as type STRING. Strings, as 
compared to character arrays, reserve the leading byte for a length 
counter Access Manager needs to determine the actual length of a 
string-valued parameter. 

4.3 Coding Numeric Key Values 

For a general discussion of coding numeric key values, refer to 
the ADDKEY function description in Section 3 of your Reference 
Manual . 

In a Pascal/MT+ environment, the most straightforward use of 
numeric keys is with the BCD REAL variables which store numeric 
quantities with the most significant digits in the first byte 
position, the least significant digits in the ninth byte, and the 
sign indicator in the tenth byte. Because the most significant byte 
comes last, negative quantities are not properly handled and you 
should avoid them. The BCD REALS provide eighteen digits including 
four decimal places. 

The following declarations and assignments overlay BCD REALS 
onto the string variables that must be passed to the Access Manager 
functions. 
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CONST 

KEYLEN BY 10; (* BCD REAL uses ten bytes *) 

TYPE 

BCDOVL = RECORD; 
LEN : BYTE; 
VAL : REAL; (* use' compiler B switch *) 



VAR 



KEYVAL,IDXVAL : STRING [KEYLEN] ; 
BCDINP,BCDOUT : "BCDOVL; 



{$1 AM80EXTR.PSC} 

BCDINP := ADDR(KEYVAL) ; (* overlay bed on string *) 
BCDINP".LEN := KEYLEN; (* set length byte of string *) 
BCDOUT := ADDR(IDXVAL) ; 
BCDOUT".LEN := KEYLEN; 

To pass key values to and from Access Manager, use KEYVAL and 
IDXVAL, respectively. To manipulate the key values as numeric 
quantities, use BCDINP".VAL and BCDOUT". VAL. For example, 

BCDINP". VAL := 123.4567; 

DRN : = BEFKEY (KEY_NO,DFILE ,DLOCK , KEYVAL , IDXVAL) ; 
IF (DRN <> 0) OR (DATVAL <> 0) THEN 
WRITELN (BCDOUT" .VAL) ; 

prints the numeric value of the index entry that immediately 
precedes 123.4567, unless no such entry exists. 

The space savings for this approach with Pascal/MT+ is only 
meaningful if numbers with more than ten digits are involved because 
BCD REALS are forced to use ten bytes, and hence the key length must 
be set to ten bytes. Note that the same type of overlaying can be 
accomplished with INTEGER variables. If you overlay integers 
instead of reals, the key length must be set as necessary (two bytes 
for regular integers and four bytes for long integers) , and then set 
KEYTYP to one. The key values are treated as signed integers. 

4.4 Using the RECREATE. SBC Utility Program 

RECREATE. SRC contains the Pascal/MT+ source code for the 
RECREATE utility program. You can change the source code in 
whatever way you want. To create RECREATE.COM, compile RECREATE. SRC 
using MTPLUS.COM and then link as follows: 

LINKMT RECREATE, AM80PASC/S ,AM80BUF ,FPREALS/S , 
RANDOMIO/S ,PASLIB/S/D: 7E00 
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4.4 RECREATE. SRC Utility 



The buffer area for RECREATE is 4,600 bytes based on these 
parameter values: 

• NNSEC% = 4 

• NBUFS% = 8 

• NDATF% = 1 

• NKEYS% = 1 

Note that only one data file and one index file are open at the same 
time while RECREATE is running. Use SETAMBUF to configure 
AM80BUF.ERL. 

Table 4-1 shows the layout and content of records in a Recreate 
Parameter File. This particular example file can be used to 
reconstruct DATABASE. SRC (see Listing 4-2) . 



Table 4-1. Example Pascal/MT+ Recreate Parameter File 



Record Type 


Contents 


Header 


1 4 


Data File 


CUSTOMER.DAT 


Data File 


100 3 


Index File 


NAME.IDX 


Index File 


10 1 1 


Index File 


Y 


Key Part 


22 8 


Index File 


NUMB.IDX 


Index File 


4 1 


Index File 


N 


Key Part 


2 4 


Index File 


ZIPC.IDX 


Index File 


11 1 1 


Index File 


Y 


Key Part 


84 9 



If you want to change the capacities of the RECREATE program 
(and, hence, its memory requirements) , note the following key Pascal 
constants: 



MAX_NO_KEYS and MAX_KEY_PARTS specify the maximum number of 
index files associated with a data file and the maximum number 
of fields comprising a key value, respectively. 

MAX_SORT is the maximum number of key values that can be 
buffered by RECREATE. SRC before being sorted and added to the 
index file being recreated. 

MAX_SPACE specifies the actual number of bytes available for 
the buffered key values. Each key value requires one more byte 
than its key length. 
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The actual number of buffered key values depends on the key 
length. For short key lengths, MAX_SORT will be the limiting 
factor. For long key lengths, MAX_SPACE will be the limiting 
factor . 



4.5 Pascal/MT+ Data File Example 

The following listing illustrates use of the primary Access 
Manager functions to update records in a data file: 



PROGRAM EXAMPLE; 

CONST 

MAX_KEY_LEN =48; 
NAME_LEN = 14; 

TYPE 

INVENTRY = RECORD 

PART_NO : ARRAY [1.. 4] OF CHAR; 
PART_NAME : ARRAY [1.. 18] OF CHAR; 
PART_QUAN : REAL; (* 10-byte BCD Real => use B switch 

of PASCAL/MT+ Compiler *) 

END; 



( * 

Variable Declarations 



*) 
VAR 

N_LOCK , S_LOCK , X LOCK ,S_FILE,X_FILE : INTEGER; 

NBUF,NKEYS,NNSEC,NDATF,ERROPT,PROGID,TIMOUT : INTEGER; 

DRN,DRN2,FILE_N0,REC0RD_LEN : INTEGER; 

DAT_BUFFER : INVENTRY; 

DATBUF_PTR : "INVENTRY; 



Listing 4-1. Pascal/MT+ Data File Example 



4-5 



Access Manager Programmer's Guide 



4.5 Data File Example 



AM80 External Declarations 



*) 

{$1 AM80EXTR.PSC) 



Exception Processing Routines 



*) 

PROCEDURE ERROR_HANDLER (LOCALE : INTEGER); 

BEGIN 

WRITELNC ERROR at ', LOCALE,' with code ',ERRCOD); 

END; 

PROCEDURE LOCK_CONFLICT (LOCALE : INTEGER); 
BEGIN 

WRITELNCLOCK Conflict at ', LOCALE,' with code ' ,LOKCOD) ; 
END; 

BEGIN 



Lock .Parameter Setup 



N LOCK 


: = 





(* 


No lock request *) 


S LOCK 


: = 


1 


(* 


Shared record lock *) 


X LOCK 


: = 


2 


(* 


Exclusive record lock *) 


S FILE 


: = 


3 


(* 


Shared file lock *) 


X FILE 


: = 


4 


(* 


Exclusive file lock *) 



System Initialization Parameters 



NBUF := 


3; ( 


NKEYS : 


= 1; ( 


NNSEC ■ 


= 4; ( 


NDATF • 


= l; ( 


ERROPT 


*= i; ( 


PROGID 


:= -l; ( 


TIMOUT 


:= 3; ( 



3 buffers 

1 index file 

512-byte index file record length 

1 data file 

Trap user errors 

Program ID assigned to MP/M console no. 

Background server time-out delay 



Listing 4-1. (continued) 
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Initialize System 



*) 

PROGID := INTUSR(PROGID,ERROPT,TIMOUT) ; 

IF ERRCOD <> THEN 

BEGIN 

ERROR_HANDLER ( 1 ) ; 

EXIT; 

END 
IF SETUP (NBUF,NKEYS,NNSEC,NDATF) <> THEN 

BEGIN 

ERROR_HANDLER(2) ; 

EXIT; 

END; 



(* 

Open Files 



*) 

FILE_NO := -1; (* Automatic file number assignment *) 

RECORD_LEN := 32; 

FILE_NAME := 'K: PART .DAT ' ; 

FILE_NO := OPNDAT (FILE_NO,S_FILE,FILEF_NAME,RECORD_LEN) ; 

IF ERRCOD <> THEN 

BEGIN 

ERROR_HANDLER ( 3 ) ; 

EXIT; 

END 
IF LOKCOD <> THEN 

BEGIN 

LOCK_CONFLICT(3) ; 

EXIT; 

END; 



( * 

Initialize Data Buffer Pointer 



*) 

DATBUF PTR := ADDR(DAT BUFFER); 



Listing 4-1. (continued) 
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Set Exclusive Lock on Data Record No. 65686 

*) 

DRN2 := 1; 

SETDAT(DRN2) ; (* Set two high-order bytes to 1, 

which implies a base of 65536 *) 
DRN := 150; (* 65686 = 65536 + 150 *) 

IF SETLOK(FILE_NO,X_LOCK,DRN) <> THEN 

BEGIN 

LOCK_CONFLICT(4) ; 

EXIT; 

END; 

( * . 

Read Data Record 

*) 

SETDAT(DRN2) ; 

IF READAT(FILE_NO,DRN,DATBUF_PTR) <> THEN 

BEGIN 

ERROR_HANDLER(4) ; 

EXIT; 

END; 

(* 

Update Data Record 

*) 

DAT BUFFER. PART QUAN := DAT BUFFER. PART QUAN - 100.00; 



Write Updated Record 



SETDAT(DRN2) ; 

IF WRTDAT(FILE_NO,DRN,DATBUF_PTR) <> THEN 

BEGIN 

ERROR_HANDLER ( 5 ) ; 

EXIT; 

END; 



( * 

Release Record Lock 



*) 

SETDAT(DRN2) ; 

IF FRELOK(FILE_NO,X_LOCK,DRN) <> THEN 
BEGIN 

LOCK_CONFLICT(6) ; 
EXP- 
END; 

(* 

Close Data File and Release File Lock 

* ( 

IF CLSDAT(FILE_N0) <> THEN 
ERROR_HANDLER(7) ; 

ELSE IF FRELOK(FILE_NO,S_FILE,0) <> THEN 
LCCK_CONFLICT(7) ; 

END. 



Listing 4-1. (continued) 
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4.6 Pascal/MT+ DATABASE Source Code 

Your Access Manager distribution disk contains sample code for 
building and maintaining a data base in Pascal/MT+. The code is 
designed so you can add or substitute your own key attributes as 
required. The sample code is on your distribution disk in a file 
called DATABASE. SRC. 

DATABASE. SRC demonstrates the integration of Access Manager 
with Pascal/MT+ applications. It builds a name and address data 
base and provides facilities for examining, updating, and/or listing 
the information contained therein. You might also want to use 
routines from DATABASE. SRC directly in your application programs. 

[SINGLE] To create DATABASE.COM, compile DATABASE. SRC with 
MTPLUS.COM and link as follows: 

LINKMT DATABASE, AM80PASC/S ,AM80BUF,PASLIB/S/D: 8500 

[MULTI] In a multiuser environment, your link statement should 
be entered as follows: 

LINKMT DATABASE, AMQ8PASC ,PASLIB/S 

Note that Listing 4-2 of DATABASE. SRC might not include recent 
changes. You should always treat the copy on your distribution disk 
as the definitive version. 
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PROGRAM DATABASE; 



DATABASE EXAMPLE VERSION 1.05 4/21/82 0751 



MAX_KEY = 2; 
MAX_FIELD = 7; 
MAX_KEY_LEN = 20; 
MAX_FLD_LEN = 20; 
NAME_LEN = 14; 
FLD NAME LEN = 18; 



ACTION LEN = 


NEW MODE = 1; 


OLD MODE = 2; 


YES = 1; 


NO = 0; 


SAVE = 1 




DELT = 2 




BACK = 3 




CONT = 4 




STOP = 5 





KEYSTR = STRING [MAX_KEY_LEN J ; 
FLDSTR = STRING [MAX_FLD_LEN] ; 
FLDCHR = ARRAY [1. . MAX_FLD_LEN ] OF CHAR; 

CUST_REC = RECORD; 

CDF : CHAR; 

FLD. : ARRAY[1..99] OF CHAR; 
END; 



WORKING VARIABLES 



KEY , TERMINAL ,TRAP_ERRORS ,TIME_OUT_TEST_DELAY ,NO_BUFFERS 
NO_NODE_SECTORS,NO_DATA_FILES,NO_KEYZ,FILE_NO : INTEGER; 
RECORD_LENGTH : INTEGER; 
SET_LENGTH,IDX_KEY,SPACE : KEYSTR; 
OLD_ACTION : INTEGER; 
FILNAME : STRING [NAME_LEN] ; 
NULL_BYT : BYTE; 
NULL CHR : CHAR; 



Listing 4-2. DATABASE. SRC Source Code 
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DATABASE FIELD & KEY DESCRIPTORS 



DATBUF : CUST REC; 

DATBUF_PTR : "*CUST_REC; 

FLD_NAME,KEY_NAME : ARRAY [0 . .MAX_FI ELD] OF STRING [FLD_NAME_LEN] ; 

FLD_LEN : ARRAY [0 . .MAX_FIELD] OF BYTE; 

OLD_FLD,NEW_FLD : ARRAY [0 . .MAX_FIELD] OF FLDSTR; 

NO_FIELDS : INTEGER; 

IDX_NAME : ARRAY [0 . .MAX_KEY] OF STRING [NAME_LEN] ; 

KEY_LEN , KEY_MAP , KE Y_TYPE , KEY_NUM , KE Y_DUP : ARRAY [ . . MAX_KE Y ] OF 

INTEGER; 
FOR_EVER : BOOLEAN; 
UNIQ_KEY,NLOCK, SLOCK, XLOCK,SFILE,XFILE,RLOCK : INTEGER; 

(* 

INTERFACE TO AM80(tm) 

AM80EXTR.PLI CONTAINS THE EXTERNAL DEFINITIONS OF THE AM-80 ROUTINES 
*) 

{$1 AM80EXTR.PSC} 

EXTERNAL FUNCTION @BDOS (FUNC: INTEGER; PARM:WORD) : INTEGER; 

PROCEDURE GO_OP_SYS; 

VAR 

DUMMY : INTEGER; 
DPARM : WORD; 



BEGIN 

DUMMY : = @BDOS ( , DPARM ) ; 

END;{GO_OP_SYS} 



PROCEDURE DATAJ3ASE; 

BEGIN 
CLRSCR; 

CASE MAIN_MENU OF 

1: DBNEW; 

2: DBSCAN; 

3: DBLIST; 

4: DBS TAT; 

5: DBSAVE; 

6: DBTERM; 

END;! OF CASE} 
END; {DATA BASE} 



Listing 4-2- (continued) 
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ENTER NEW CUSTOMERS 



PROCEDURE DBNEW; 
VAR 

KEY, LOCK_CODE,NDRN,DRN, CHOICE : INTEGER; 

SAVE_KEY,LDRN,NO_LISTED : INTEGER; 

ROUTE : CHAR; 

CONTINUE, STAYPUT : BOOLEAN; 

L_VALUE,U_VALUE,CONV_TARGET, TARGET : KEYSTR; 

ACTION : INTEGER; 



BEGIN 

ACTION := SAVE; 
WHILE (ACTION = SAVE) DO 
BEGIN 

ACTION := NEWDAT; 
LOCK_CODE := 0; 
IF ACTION = SAVE THEN 
BEGIN 

NDRN := UPDATE (0) ; 

LOCK_CODE := FRELOK (FILE_NO,XLOCK,NDRN) 
END; 

IF LOCK_CODE <> THEN 

LOCK_TYPE(8) ; 
END; 
END; {DBNEW} 



SCAN/UPDATE/DELETE CUSTOMERS 



*) 

PROCEDURE DBSCAN; 
VAR 

KEY, LOCK_CODE, NDRN, DRN, CHOICE : INTEGER; 

SAVE_KEY,LDRN,NO_LISTED : INTEGER; 

ROUTE : CHAR; 

CONTINUE, STAYPUT : BOOLEAN; 

L_VALUE,U_VALUE,CONV_TARGET, TARGET : KEYSTR; 

ACTION : INTEGER; 



Listing 4-2. (continued) 
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BEGIN 

KEY := SEARCH_KEY; 
WRITELN; 

WRITELN ('Enter target value for ' ,KEY_NAME [KEY] , ' , • ) ; 
WRITE (' or enter a period (.) to see main menu>>'); 
RE ADLN (TARGET) ; 
IF TARGET <> ' . ' THEN 
BEGIN 

CONV_TARGET := TARGET; 
KEY_FORMAT ( KEY , CONVJTARGET ) ; 
STAYPUT := TRUE; 
WHILE (STAYPUT) DO 
BEGIN 
DRN := SERKEY(KEY_NUM[KEY] ,FILE_NO, SLOCK, 

CONV_TARGET , IDX_KEY ) ; 
IF ERRCOD <> THEN 

ERRORJTYPE (KEY , 2 ) ; 
IF LOKCOD <> THEN 

STAYPU1 := CHECK_LOCK(KEY,DRN) 
ELSE 

STAYPUT :=FALSE; 
END; 

OLD_ACTION := CONT; 
CONTINUE := TRUE? 

WHILE (CONTINUE) .JJD (DRN <> 0) DO 
BEGIN 

LDRN := DRN; 
READ_CUST(DRN) ; 
ACTION := OLDDAT(DRN); 
SAVE_KEY := KEY; 
IF ACTION = SAVE THEN 

DRN := UPDATE (DRN); 
IF ACTION = DELT THEN 

DELETE (DRN) ; 
IF (ACTION <> DELT) AND (FRELOK (FILE_NO,RLOCK,LDRN) <> 0) 

THEN LOCK_TYPE ( 2 ) ; 
IF (ACTION = SAVE) OR (ACTION = DELT) THEN 

BEGIN 

KEY := SAVE_KEY; 

ACTION := OLD_ACTION; 

END; 
OLD_ACTION := ACTION; 

CONVJTARGET : = COPY (IDX_KEY , 1 , KEY_LEN [KEY] ) ; 
IDX_KEY := SET_LENGTH; 
LOCK_CODE := 0; 

STAYPUT := TRUE; 
WHILE (STAYPUT) DO 
BEGIN 

IF ACTION = CONT THEN 
BEGIN 
DRN := AFTKEY(KEY_NUM[KEY] ,FILE_NO, 

SLOCK , CONVJTARGET , IDX_KEY ) ; 
LOCK CODE := LOKCOD; 



Listing 4-2. (continued) 
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END; 
IF ACTION = BACK THEN 
BEGIN 
DRN := BEFKEY(KEY_NUM[KEY] ,FILE_NO, 

SLOCK, CONV_TARGET,IDX_KEY) ; 
LOCKCODE := LOKCOD; 
END? 

IF LOCK_CODE <> THEN 

STAYPOT := CHECK_LOCK ( KEY , DRN ) 
ELSE 

STAYPUT := FALSE; 
END; 

IF ACTION = STOP THEN 

CONTINUE := FALSE; 
END; 



WRITELN; 

WRITELN ( ' SCAN ENDED ' ) ; 

PAUSE; 



END; 
END;{DBSCAN} 



LIST CUSTOMERS 



*) 

PROCEDURE DBLIST; 
VAR 

KEY, LOCK_CODE,NDRN, DRN, CHOICE : INTEGER; 

SAVE_KEY,LDRN,NO_LISTED : INTEGER; 

ROUTE : CHAR; 

CONTINUE, STAYPUT : BOOLEAN; 

L_VALUE , U_VALUE , CONVJTARGET , TARGET : KEYSTR; 

ACTION : INTEGER; 



BEGIN 

KEY := SEARCH_KEY; 

WRITELN; 

WRITE('Do you want listing routed to printer (Y/N) >>'); 

READLN (ROUTE) ; 

IF ROUTE = 'y' THEN ROUTE := 'Y'; 

WRITELN; 
WRITELN ; 
WRITELN ( 
'Enter lower and upper limits for * ,KEY_NAME [KEY] , ' listing;'); 
WRITE (' separate values with a space >>*) ; 
READ(L VALUE); 



Listing 4-2. (continued) 
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READLN(U_VALUE) ; 

KEY_FORMAT ( KE Y , L_VALUE ) ; 

KE Y_FORMAT ( KE Y , U_VALUE ) ; 

DRN := SERKEY(KEY_NUM[KEY] ,FILE_NO, SLOCK, 

L_VALUE,IDX_KEY) ; 
IF LOKCOD <> THEN 

SKIP_LOCK(KEY,DRN) ; 

NO_LISTED := 0; 

WHILE (DRN <> 0) AND (COMPARE (KEY , IDX_KEY,U_VALUE) <= 0) DO 
BEGIN 

READ_CUST(DRN) ; 
PRINT_CUST (ROUTE) ; 
NO_LISTED := NO_LISTED + 1; 
IF FRELOK(FILE_NO, SLOCK, DRN) <> THEN 

LOCK_TYPE(4) ; 
L_VALUE : = COPY ( IDX_KEY , 1 , KEY_LEN [ KEY] ) ; 
IDX_KEY := SET_LENGTH; 
DRN := AFTKEj (KEY_NUM[KEY] ,FILE_NO, SLOCK, 

L_VALUE,IDX_KEY) ; 
IF LOKCOD <> THEN 

SKIP_LOCK(KEY,DRN) ; 
END; 

IF DRN <> THEN 

LOCK_CODE := FRELOK (FILE_NO, SLOCK, DRN) 
ELSE 

LOCK_CODE := 0; 
IF LOCK_CODE <> THEN 

LOCK_TYPE(5) ; 

WRITELN; 

WRITELN(NO_LISTED, ' records listed.'); 
PAUSE; 
END; { DE-LIST } 



DATABASE STATISTICS 



*) 

PROCEDURE DBSTAT; 
VAR 

KEY, LOCK_CODE,NDRN, DRN, CHOICE : INTEGER; 

SAVE_KEY,LDRN,NO_LISTED : INTEGER; 

ROUTE : CHAR; 

CONTINUE, STAYPUT : BOOLEAN; 

L_VALUE,U_VALUE,CONV_TARGET, TARGET : KEYSTR; 

ACTION : INTEGER; 



Listing 4-2. (continued) 
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CLRSCR; 

WRITELN (FILNAME, ' has ' ,GETDFS (FILE_NO) , 

' records; currently, ' ,GETDFU (FILE_NO) , 

' of them are in use.'); 
WRITELN; 
WRITELN ; 
WRITELN (' INDEX' , 'ENTRIES' : 30) ; 

WRITELN ( ' ' , ' ' : 22 ) ; 

FOR KEY := TO MAX_KEY DO 

WRITELN (KEY NAME [KEY] : 16 , ' ' : 16 ,NOKEYS (KEY) : 7) ] 



WRITELN; 
WRITELN; 
PAUSE; 
END;{DBSTAT} 



SAVE DATABASE UPDATES & RESTART 



*) 

PROCEDURE DBSAVE; 
VAR 

KEY, LOCK_CODE,NDRN,DRN, CHOICE : INTEGER; 

SAVE_KEY,LDRN,NO_LISTED : INTEGER; 

ROUTE : CHAR; 

CONTINUE, STAYPUT : BOOLEAN; 

L_VALUE,U_VALUE,CONV_TARGET, TARGET : KEYSTR; 

ACTION : INTEGER; 



BEGIN 

IF SAVDAT(FILE_NO) <> THEN 

ERROR_TYPE(0,7) ; 
FOR KEY := TO MAX KEY DO 

IF SAVIDX(KE*Y_NUM[KEY] ) <> THEN 
ERROR TYPE (KEY, 3) ; 



END; { DBSAVE } 



SAVE DATABASE UPDATES & TERMINATE 



*) 

PROCEDURE DBTERM; 
VAR 

KEY, LOCK_CODE,NDRN,DRN, CHOICE : INTEGER; 

SAVE_KEY,LDRN,NO_LISTED : INTEGER; 

ROUTE : CHAR; 



Listing 4-2. (continued) 
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CONTINUE, STAYPUT : BOOLEAN; 

L_VALUE,U_VALUE,CONV_TARGET, TARGET : KEYSTR; 
ACTION : INTEGER; 

BEGIN 

IF CLSDAT(FILE_NO) <> THEN 

ERROR_TyPE(0,15) ; 
FOR KEY := TO MAX_KEY DO 

IF CLSIDX(KEY_NUM[KEY] ) <> THEN 
ERRORJTYPE ( KEY , 16 ) ; 
IF FRELOK(FILE_NO,SFILE,0) <> THEN 
ERROR_TYPE(0,13) ; 

WRITELN; 

WRITELNC *** SUCCESSFUL TERMINATION ***•); 
FOR_EVER := FALSE; 
END; {dBTERM} 

(* 

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 

BEGINNING OF UTILITY FUNCTIONS 



CLEAR SCREEN ROUTINE 



PROCEDURE CLRSCR; 
VAR 

DUMMY : INTEGER; 



BEGIN 

FOR DUMMY := 1 TO 24 DO 

WRITELN; 
END;{CLRSCR} 



MAIN MENU ROUTINE 



FUNCTION MAIN_MENU : INTEGER; 
VAR 

OP : INTEGER; 

BEGIN 



Listing 4-2. (continued) 
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WRITELNC ':19,' AM-80(tm) DEMONSTRATION'); 

WRITELN; 

WRITELNC ':19,' Customer Database Operations') ; 

WRITELNC ':19,' Terminal ', TERMINAL) ; 

WRITELN ( ' ':19,' **************************** i ) . 

WRITELN; 

WRITELN; 

WRITELNC 1. Enter New Customers'); 

WRITELNC 2. Scan/Update/Delete Customer Records') 

WRITELNC 3. List Customer Records'); 

WRITELNC 4. Database Statistics'); 

WRITELNC 5. Save All Files & Restart Operations') 

WRITELNC 6. Terminate Operations'); 

OP := 0; 

WHILE (OP < 1) OR (OP > 6) DO 

BEGIN 

WRITELN ; 

WRITE ('Enter desired operation number>>'); 

READLN(OP) ; 

END; 
MAIN MENU := OP; 
END;TmAIN MENU} 



SELECT SEARCH KEY ROUTINE 



*) 

FUNCTION SEARCH_KEY : INTEGER; 
VAR 

KEY,KEY_NO : INTEGER; 

BEGIN 

CLRSCR; 

WRITELNC ': 24, 'Customer Database Search Keys') 

WRITELN; 

WRITELN; 

WRITELN; 

FOR KEY := TO MAX_KEY DO 
BEGIN 

KEY_NO := KEY + 1; 

WRITELN (KEY_NO, ' - ' ,KEY_NAME [KEY] ) 
END; 

KEY := 0; 

WHILE (KEY < 1) OR (KEY > NO_KEYZ) DO 

BEGIN 

WRITELN; 

WRITELN; 

WRITE ('Enter desired key number>>'); 



Listing 4-2. (continued) 
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READ LN (KEY) ; 

END; 
SEARCHJKEY := KEY-1; 
END; {SEARCH KEY} 



ERROR HANDLING 



PROCEDURE ERROR_TYPE( INFO, LOCALE : INTEGER); 
VAR 

DUMMY : INTEGER; 

PROCEDURE ET_CLOSE; 
VAR 

T_KEY : INTEGER; 

BEGIN 

DUMMY := CLSDAT (FILE_NO) ; 

FOR T_KEY ;= TO MAX_KEY DO 

IF T_KEY <> INFO THEN DUMMY := CLSIDX (KEY_NUM [T_KEY] ) 
ET_STOP; 
END; 

PROCEDURE ET_PCLOSE; 
VAR 

L_KEY,T_KEY : INTEGER; 

BEGIN 

L_KEY := INFO + 1; 

IF L_KEY > MAX_KEY THEN GO_OP_SYS ; 

FOR T_KEY := L_KEY TO MAX_KEY DO 

DUMMY := CLSIDX (KEY_NUM [T_KEY] ) ; 
END; 

PROCEDURE ET_STOP; 

BEGIN 

WRITELN; 

WRITELNC DAT ABASE TERMINATING WITH ERROR CODE #',ERRCOD); 

GO_OP_SYS ; 

END; 

BEGIN 

WRITELN; 

WRITELN; 

WRITE ('User Error #',ERRCOD,' occurred while trying to '); 

CASE LOCALE OF 



Listing 4-2. (continued) 
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1 : WRITELN ( * open ' , IDX_NAME [ INFO] ) ; 

2: WRITELN (' search • , KEY_NAME [ INFO] , ' Index File'); 

3 : WRITELN ( ■ save ' , IDX_NAME [ INFO] ) ; 

4: WRITELN ('remove old key from * ,IDX_NAME [INFO] ) ; 

5: WRITELN (' enter key into ' ,IDX_NAME[INFO] ) ; 

6: WRITELN ('delete key from ' ,IDX_NAME[INFO] ) ; 

7: BEGIN 

WRITELN ( ' save ' ,FILNAME) ; 

INFO := -1; 
END; 
&: WRITELNCget a new data record',' ( ' ,FILE_NO, ' ) ' ) ; 
9: WRITELN ('delete data record #',INF0); 
10: WRITELN (' open ',FILNAME,' ( ' ,FILE_NO, ' ) ' ) ; 
11: WRITELN ('read data record #',INFO); 
12: WRITELN ('write data record #*,INFO); 
13: WRITELN (' release shared file lock on ' ,FILNAME) ; 
14: BEGIN 

WRITELN (' initialize user.'); 

GO_OP_SYS ; 
END; 
15: BEGIN 

WRITELN ('close ' ,FILNAME) ; 

INFO := -1; 
END; 
16: WRITELN ('close ' ,IDX_NAME [INFO] ) ; 

END; {OF CASE} 

IF (LOCALE = 1) OR ((LOCALE > 7) AND (LOCALE < 14)) THEN 

ET_STOP 
ELSE IF (LOCALE = 2) OR ((LOCALE > 3) AND (LOCALE < 7)) THEN 

ETCLOSE 
ELSE 

ETJPCLOSE; 

END ; { ERROR_TYPE } 

PROCEDURE LOCKJTYPE (LOCALE : INTEGER) ; 
VAR 

T_KEY, DUMMY : INTEGER; 

BEGIN 

WRITELN ('Lock Type: ', LOCALE,' Lock Code: * ,LOKCOD) ; 

DUMMY := CLSDAT (FILE_NO) ; 

FOR T_KEY := TO MAX_KEY DO 

DUMMY := CLSIDX (KEY_NUM[T_KEY] ) ; 
GO_OP_SYS ; 
END; { LOCKJTYPE} 



READ DATA RECORD ROUTINE 



Listing 4-2. (continued) 
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*) 

PROCEDURE READ_CUST(DRN : INTEGER); 
VAR 

FLD,CHR,POS_PTR : INTEGER; 

TMPBYT : "BYTE; 

TMP_FLD : FLDSTR; 

FLDPTR : "FLDCHR; 

BEGIN 

IF READAT(FILE_NO,DRN,DATBUF_PTR) <> THEN 
ERRORJTYPE (DRN , 11) ; 

TMPBYT := ADDR (TMP_FLD) ; (* POINTER LENGTH BYTE OF STRING *) 
FLDPTR := ADDR (TMP_FLD) +1; (* PTR TO BODY OF STRING *) 

POS_PTR := 0; 

FOR FLD := TO MAX_FIELD DO 

BEGIN 

TMPBYT" := FLD_LEN [FLD] ; 

FOR CHR := 1 TO TMPBYT" DO 

FLDPTR" [CHR] := DATBUF.FLD [POS_PTR + CHR]; 

WHILE (FLDPTR" [TMPBYT"] = ' ') AND (TMPBYT" > 0) DO 

TMPBYT" := TMPBYT" - 1; 
OLD^FLD[FLD] := TMP_FLD; 
POS_PTR := POS_PTR + FLD_LEN [FLD] ; 
END; 



END; {READ_CUST} 



LIST CUSTOMER RECORD ROUTINE 



*) 

PROCEDURE PRINT_CUST (ROUTE : CHAR) ; 
VAR 

DUMMY : INTEGER; 

LISTJFILE : TEXT; 

BEGIN 

IF ROUTE = 'Y 1 THEN 

ASSIGN (LIST_FILE , ' LST : ' ) 
ELSE 

ASSIGN (LIST_FILE, 'CON: ') ; 

WRITELN(LIST_FILE) ; 

WRITELN(LIST_FILE, ■ ' : 4 , OLD_FLD [ ] : 10 ,OLD_FLD [7] ) ; 

WRITELN (LIST FILE, ' ■ : 24 ,OLD_FLD [1] , ■ ' ,OLD_FLD [2] ) ; 
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WRITELN (LIST_FILE , ' ' : 24 ,OLD_FLD [3] ) ; 

WRITELN(LIST_FILE,' ' : 24 ,OLD_FLD [4 ] , ' , ' r 0LD_FLD[5] , ' ' ,OLD_FLD [6] ) 

WRITELN (LIST_FILE) ; 

CLOSE (LIST_FILE. DUMMY) ; 

END; {PRINT_CUST} 



PAUSE ROUTINE 



PROCEDURE PAUSE; 
VAR 



NULL : CHAR; 

BEGIN 

WRITE ('Press "RETURN" to continue 

READLN(NULL) ; 

END; {PAUSE} 



CONVERT TARGET VALUE TO KEY FORMAT ROUTINE 



*) 

PROCEDURE KEY_FORMAT(KEY : INTEGER; VAR TARGET : KEYSTR); 
VAR 

TEMP : STRING [40]; 

BEGIN 

IF UNIQ_KEY = KEY THEN 

EXIT 
ELSE 

BEGIN 

TEMP := CONCAT (TARGET, SPACE ) ; 

TEMP :=COPY(TEMP,l,KEY_LEN[KEY]-2) ; 

TARGET := CONCAT (TEMP,NULL_CHR,NULL_CHR) 

END; 
END;{KEY_FORMAT} 



COMPARE IDXJKEY & U_VALUE ROUTINE 

*) 

FUNCTION COMPARE (KEY : INTEGER; IDXVAL,UPVAL : KEYSTR) : INTEGER; 
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KL : INTEGER; 

C1,C2 : STRING [40]; 

BEGIN 

IF KEY = UNIQJCEY THEN 

KL := KEY_LEN[KEY] 
ELSE 

KL := KEY LEN[KEY]-2; 



CI 
CI 
C2 
C2 



CONCAT ( IDXVAL , SPACE) ; 
COPY(Cl,l,KL) ; 
CONCAT (UPVAL , SPACE ) ; 
COPY(C2,l,KL) ; 



IF C1<C2 THEN 

COMPARE := -1 
ELSE IF C1>C2 THEN 

COMPARE := 1 
ELSE 

COMPARE := 0; 
END; {COMPARE} 



CHECK LOCK ROUTINES 



*) 

PROCEDURE SKIP_LOCK(KEY,DRN : INTEGER); 
VAR 

L_VALUE : KEYSTR; 

BEGIN 

WHILE (DRN <> 0) AND (LOKCOD <> 0) DO 

BEGIN 

L_VALUE := COPY ( IDXJKEY , 1 , KEY_LEN [KEY] ) ; 

IDX_KEY := SET_LENGTH; 

DRN := AFTKEY(KEY_NUM[KEY] ,FILE_NO, SLOCK, 
L_VALUE,IDX_KEY) ; 

END; 
END;{SKIP_L0CK} 

FUNCTION CHECK_LOCK(KEY,DRN : INTEGER) : BOOLEAN; 
VAR 

CONVJTARGET : KEYSTR; 

DUMMY : CHAR; 

BEGIN 
WRITELN; 
WRITE ( 
'Enter a ,"W n if you want to wait for locked record (s) >>') ; 
READLN (DUMMY) ; 
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IF (DUMMY = 'W') OR (DUMMY = 'w') THEN 
BEGIN 

CHECK_LOCK := TRUE; 
EXIT; 
END; 

WHILE (DRN <> 0) AND (LOKCOD <> 0) DO 
BEGIN 

CONVJTARGET := COPY (IDX_KEY,1,KEY_LEN [KEY] ) ; 
IDX_KEY := SET_LENGTH; 
IF OLD_ACTION = CONT THEN 

DRN := AFTKEY(KEY_NUM[KEY] ,FILE_NO, 
SLOCK, CONV_TARGET,IDX_KEY) 
ELSE 

DRN := BEFKEY(KEY_NUM[KEY] ,FILE_NO, 
SLOCK , CONV_TARGET , I DX_KEY ) ; 
END; 
CHECK_LOCK := FALSE; 
END;lCHECK_LOCK} 



WARNING MESSAGES 

*) 

PROCEDURE WARN INGJTYPE ( KEY, LOCALE, RET_CODE : INTEGER); 

BEGIN 
WRITELN ; 

WRITE ('WARNING. . .Return Code #',RET_CODE, 
' occurred while trying to '); 

CASE LOCALE OF 

1: WRITELN ('remove old key from ' , IDX_NAME [KEY] ) ; 

2: WRITELN ('enter key into ' ,IDX_NAME[KEY] ) ; 

3: WRITELN ('delete key from ' , IDX_NAME [KEY] ) ; 



END; {OF CASE} 

PAUSE; 

END; {WARNING TYPE} 



ADD NEW KEY VALUE ROUTINE 
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PROCEDURE ADD_A_KEY(KEY,DRN : INTEGER); 
VAR 

RET_CODE,K_FLD : INTEGER; 



(* 
*) 



BEGIN 

K FLD := KEY MAP [KEY]; 



REMOVE OLD KEY VALUE 



RET_CODE := DELKEY(KEY_NUM[KEY] ,FILE_NO, 
XLOCK,OLD_FLD(K_FLD] ,DRN) ; 

IF ERRCOD <> THEN 

ERRORJTYPE (KEY , 4 ) ; 
IF LOKCOD <> THEN 

LOCK_TYPE(6) ; 
IF RETCODE <> 1 THEN 

WARNING TYPE (KEY, 1, RET CODE); 



ADD NEW KEY VALUE 



RET_CODE := ADDKEY (KEY_NUM [KEY] ,FILE_NO, 
XLOCK,NEW_FLD[K_FLD] ,DRN) ; 

IF ERRCOD <> THEN 

ERRORJTYPE ( KEY , 5 ) ; 
IF LOKCOD <> THEN 

LOCK_TYPE(7) ; 
IF RET_CODE <> 1 THEN 

WARNING TYPE (KEY, 2, RET CODE); 



end;{add_a_key} 



WRITE NEW DATA RECORD ROUTINE 



*) 

PROCEDURE WRITE_CUST(DRN' : INTEGER) 
VAR 

FLD,CHR,POS_PTR : INTEGER; 

TMPBYT : "BYTE; 

TMP_FLD : FLDSTR; 

FLDPTR : "FLDCHR; 

BEGIN 

DATBUF.CDF := NULL CHR; 
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TMPBYT := ADDR(TMP_FLD) ; (* POINTER LENGTH BYTE OP STRING *) 
FLDPTR := ADDR(TMP_FLD) + 1; (* PTR TO BODY OF STRING *) 

POS_PTR := 0; 

FOR FLD := TO MAX_FIELD DO 

BEGIN 

TMP_FLD := NEW_FLD [FLD] ; 

FOR CHR := 1 TO TMPBYT" DO 

DATBUF.FLD[POS_PTR + CHR] := FLDPTR" [CHR] ; 

WHILE (TMPBYT" < FLD_LEN [FLD] ) DO 

BEGIN 

TMPBYT" := TMPBYT" + 1; 

DATBUF.FLD[POS_PTR + TMPBYT"] := ' '; 

END; 
POS_PTR := POSPTR + FLD_LEN [FLD] ; 
END; 

IF WRTDAT(FILE_NO,DRN,DATBUF_PTR) <> THEN 

ERRORJTYPE (DRN , 12) ; 
END;{WRITE_CUST} 



DELETE KEY VALUE FROM INDEX ROUTINE 



*) 
PROCEDURE DEL_A_KEY(KEY,DRN : INTEGER); 
VAR 

RET_CODE,K_FLD : INTEGER; 

BEGIN 

K_FLD := KEY_MAP[KEY] ; 

RET_CODE := DELKEY(KEY_NUM[KEY] ,FILE_NO, 
XLOCK,OLD_FLD[K_FLD] ,DRN) ; 

IF ERRCOD <> THEN 

ERRORJTYPE ( KEY , 6 ) ; 
IF LOKCOD <> THEN 

LOCK_TYPE(10) ; 
IF RET_CODE <> 1 THEN 

WARNING TYPE(KEY,3,RET_CODE) ; 



END; {DEL AJKEy} 



UPDATE INDICES & DATA FILE ROUTINE 
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*) 

FUNCTION UPDATE (DATA_RECORD : INTEGER) : INTEGER; 
VAR 

FLD, KEY : INTEGER; 

BEGIN 

IF DATA_RECORD = THEN 
BEGIN 

DATA_RECORD : = NEWREC ( F I LE_NO , XLOC K ) ; 
IF ERRCOD <> THEN 

ERRORJTYPE (0,8); 
IF LOKCOD <> THEN 

LOCK_TYPE(3) ; 
END; 

UPDATE := DATA_RECORD; 
FOR KEY := TO MAX_KEY DO 

BEGIN 

FLD := KEY MAP [KEY]; 

IF OLD_FLDTFLD] <> NEW_FLD[FLD] THEN 
ADD_A_KEY(KEY,DATA_RECORD) ; 

END; 

FOR FLD := TO MAX_FIELD DO 

IF OLD_FLD[FLD] <> NEW_FLD[FLD] THEN 

BEGIN 

WRITE_CUST(DATA_RECORD) ; 

EXIT; 

END; 
END; {UPDATE} 



DELETE INDEX & DATA FILE ENTRY ROUTINE 



*) 

PROCEDURE DELETE (DATA_RECORD : INTEGER) ; 
VAR 

FLD, KEY : INTEGER; 

BEGIN 

FOR KEY := TO MAX_KEY DO 

BEGIN 

FLD := KEY_MAP[KEY] ; 

IF OLD_FLD[FLD] <> " THEN 

DEL_A_KEY ( KEY , DATA_RECORD ) ; 

END; 

IF RETREC(FILE_NO,XLOCK,DATA_RECORD) <> . THEN 

ERRORJTYPE (DATA_RECORD , 9 ) ; 
IF LOKCOD <> THEN 
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L0CK_TYPE(9) ; 
END; {DELETE} 



(* 



NEW DATA ENTRY ROUTINE 



FUNCTION NEWDAT : INTEGER; 



TMPFLD : STRING [40]; 
UNIQUE : BOOLEAN; 
TMPDAT : INTEGER; 
FLD,OP_VAL,FLD_NO : INTEGER; 
OP1 : CHAR; 
OP1 BYT : BYTE; 



111; 

BEGIN 

FOR FLD := TO MAX FIELD DO 
0LD_FLD[FLDT := ' * ; 

CLRSCR; 



WRITELNC ':19, 'Enter New Customer Information'); 

WRITELN (' ' :L9, '******************************')• 

WRITELN; 

WRITELN; 

WRITELN ( 

' [Press "RETURN" for customer # to see main menu.]'): 
WRITELN; 

FOR FLD := TO MAX_FIELD DO 
BEGIN 
FLD_NO := FLD + 1; 

WRITE(FLD_NO:6, ' - * ,FLD_NAME [FLD] : 20, 

' (' ,FLD_LEN[FLD] :2, ') >>'); 
READLN (NEW_FLD [FLD] ) ; 
IF (FLD = KEY_MAP[UNIQ_KEY] ) AND (NEW_FLD [FLD] = ") 

THEN BEGIN 

NEWDAT := STOP; 

EXIT; 

END; 

IF FLD = KEY_MAP[UNIQ_KEY] THEN 
BEGIN 
NEW FLD [FLD] := CONCAT (' 0000 ', NEW FLD [FLD] ); 
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RIGHT (NEWFLD [FLD] ,FLD_LEN [FLD] ) ; 
UNIQUE := TEST_UNIQUENESS; 
END 
ELSE 

BEGIN 

TMPFLD := CONCAT (NEW_FLD [FLD] , 

'); 

NEW_FLD[FLD] := COPY (TMPFLD, 1,FLD_LEN [FLD] ) ; 

UNIQUE := TRUE; 

END; 

IF "UNIQUE THEN GOTO 111; 
END; 

WHILE (FOR_EVER) DO 
BEGIN 
WRITELN; 
WRITELN; 
WRITELN; 

WRITELN (' ': 19 , 'Current customer information'); 
WRITELN; 

FOR FLD := TO MAX_FIELD DO 
BEGIN 

FLD_NO := FLD + 1; 
WRITELN (FLD_NO: 6, ' - ' ,FLD_NAME [FLD] : 20 , ' ■ , 

NEW_FLD[FLD] ) ; 
END; 



OP_VAL := 0; 

WHILE (OP_VAL < 1) OR (OP_VAL > NO_FIELDS) DO 
BEGIN 
WRITELN; 
WRITELN; 
WRITELN ( 
'Enter S to save data. Field # to change data,'); 

WRITE ( 
'D to delete data, or E to end input >>') ; 

READLN(OPl) ; 
TMPDAT := 0; 
IF (OP1 = 'S') OR (OP1 = 's') THEN 

TMPDAT := SAVE; 
IF (OP1 = "D") OR (OP1 = 'd') THEN 

TMPDAT := DELT; 
IF (OP1 = 'E') OR (OP1 = 'e') THEN 

TMPDAT := STOP; 
IF TMPDAT <> THEN 

BEGIN 

NEWDAT := TMPDAT; 

EXIT; 

END; 
OPl_BYT := OP1; 
OP_VAL := OP1 BYT - 48; 
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END; 
UPDATE_FIELD(OP_VAL) ; 
END; 

END;{NEWDAT} 

FUNCTION OLDDAT(DRN: INTEGER) : INTEGER; 

VAR 

UNIQUE : BOOLEAN; 
TMPDAT : INTEGER; 
FLD,OP_VAL,FLD_NO : INTEGER; 
OP1 : CHAR; 
OP1 BYT : BYTE; 



FOR FLD := TO MAX_FIELD DO 

NEW_FLD[FLD] : = OLD_FLD [ FLD ] ; 

CLRSCR; 

WHILE (FOR_EVER) DO 
BEGIN 
WRITELN; 
WRITELN; 
WRITELN ; 

WRITELNC ': 19, 'Current customer information'); 
WRITELN; 

FOR FLD := TO MAX_FIELD DO 
BEGIN 

FLD_NO := FLD + 1; 
WRI TELN (FLD_NO : 6 , ' - ' , FLD_NAME [ FLD ] : 2 , ' ' , 

NEW_FLD[FLD] ) ; 
END; 

OP_VAL := 0; 

WHILE (OP_VAL < 1) OR (OP_VAL > NO_FIELDS) DO 
BEGIN 
WRITELN ; 
WRITELN; 
WRITELN ( 
'Enter C to continue scan. Field # to change data, S to save changes,') 

WRITE ( 
'D to delete data, B for back scan, or E to end scan >>'); 

READLN(OPl) ; 
TMPDAT := 0; 
IF (OP1 = 'C') OR (OP1 = 'c') THEN 

TMPDAT := CONT; 
IF (OP1 = 'S') OR (OPl = 's') THEN 

TMPDAT := SET_XLOCK (OPl,DRN) ; 
IF (OPl = 'D') OR (OPl = 'd') THEN 

TMPDAT := SET XLOCK (OPl,DRN) ; 
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IF (0P1 = *B') OR (0P1 = 


'b'] 


l THEN 




TMPDAT := BACK; 








IF (OP1 = 'E') OR (OP1 = 


■e') 


I THEN 




TMPDAT := STOP; 








IF TMPDAT <> THEN 








BEGIN 








OLDDAT := TMPDAT; 








EXIT; 








END; 








OP1 BYT := OP1; 








OP VAL := OP1 BYT - 48; 








END; 








UPDATEJFIELD (OP_VAL) ; 






END; 








:nd; Iolddat} 








SET_XLOCK(OP : 


: CHA1-, DRN : INTEGER) : INTEGER; 







VAR 

DUMMY : CHAR; 

BEGIN 

DUMMY : = ' W * ; 

WHILE (DUMMY = 'W ) AND (SETLOK (FILE_NO,XLOCK ,DRN) <> 0) DO 

BEGIN 

WRITELN; 

WRITELN ( 'Customer update on hold due to record lock') 

WRITE ( 
'Enter W if you want to wait or any other key to cancel update>>'); 

READ LN (DUMMY) ; 

IF DUMMY = 'w' THEN DUMMY := 'W'; 

END; 



IF DUMMY = 'W' 


THEN 








BEGIN 










IF OP = 


= 'S' 


THEN 








SET 


XLOCK 


:= SAVE 




ELSE 












SET 


XLOCK 


:= DELT; 




END 








ELSE 












SET XLOCK := 


= OLD ACTION; 


END; | 


[set_xlock] 


\ 







UPDATE DATA FIELD ROUTINE 



PROCEDURE UPDATE FIELD (FLD NO : INTEGER); 
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VAR 



TMPFLD : STRING[40]; 
TEST : BOOLEAN; 
FIELD_NO : INTEGER; 

BEGIN 

FIELD_NO := FLD_NO-l; 

TEST := FALSE; 

WHILE ("TEST) DO 
BEGIN 
WRITELN; 

WRITE ('Input new ' ,FLD_NAME[FIELD_NO] ,*>>') ; 
READLN (NEW_FLD [FIELD_NO] ) ; 

IF FIELD_NO = KEY_MAP[UNIQ_KEY] THEN 

BEGIN 

NEW_FLD [FIELD_NO] := CONCAT ( * 0000 ■ ,NEW_FLD [FIELD_NO] ) : 

RIGHT (NEW_FLD[FIELD_NO] ,FLD_LEN [FIELD_NO] ) ; 

END 
ELSE 

BEGIN 

TMPFLD := CONCAT (NEW_FLD [FIELD_NO] , 

'); 

NEW_FLD [FIELD_NO] : = COPY (TMPFLD , 1 , FLD_LEN [FIELD_NO] ) ; 
END; 

IF (FIELD_NO = KEY_MAP [UNIQKEY] ) AND (NEW_FLD[FIELD_NO] <> 
OLD_FLD [ FI ELD_NO] ) THEN 

TEST := TESTJJNIQUENESS 
ELSE 

TEST := TRUE; 
END; 
END; {UPDATE_FIELD} 



CUST # UNIQUENESS TEST ROUTINE 



*) 

FUNCTION TESTJJNIQUENESS : BOOLEAN; 
VAR 

TEMP : INTEGER; 

TEST s FLDSTR; 

BEGIN 

TEST := NEW_FLD[KEY_MAP[UNIQ_KEY] ] ; 

TEMP := GETKEY(UNIQ_KEY,0,NLOCK,TEST) ; 

IF LOKCOD <> THEN 

LOCK TYPE (12) ; 
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IF TEMP = THEN 

TESTJJNIQUENESS := TRUE 
ELSE 

BEGIN 

WRITELN; 

WRITELNC *** Already Assigned ***'); 

WRITELN; 

TESTJJNIQUENESS := FALSE; 

END; 
END; {TEST UNIQUENESS} 



RIGHT STRING ROUTINE 

*). 
PROCEDURE RIGHT (VAR FLDVAL : FLDSTR; FLDLEN : INTEGER); 

BEGIN 

FLDVAL := COPY (FLDVAL , LENGTH (FLDVAL) -FLDLEN+1, FLDLEN) ; 

END; {RIGHT} 

(* 

END OF UTILITY FUNCTIONS 

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 



SET-UP DATABASE FIELD & KEY DESCRIPTORS 



*) 
BEGIN 
NO_FIELDS := MAX_FIELD + 1; 

FLD_NAME[0] := 'Customer Number 1 

FLD_LEN[0] := 4; 

FLD_NAME[1] := 'First Name'; 

FLD_LEN[1] := 16; 

FLD_NAME[2] := 'Last Name'; 

FLD_LEN[2] := 20; 

FLD_NAME[3] := 'Street Address'] 

FLD_LEN[3] := 20; 

FLD_NAME[4] := 'City'; 

FLD_LEN[4] s= 20; 

FLD NAME[5] := 'State'; 
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FLD_LEN[5] := 2; 

FLD_NAME[6] := 'Zipcode'; 

FLD_LEN[6] := 9; 

FLD_NAME[7] := 'Customer Status'; 

FLD LEN[7] := 8; 



KEY LEN[0] :=10 










KEY TYPE[0] :=0 










KEY MAP[0] :=2 


(* 


KEY 


= LAST NAME 


*) 


KEY LEN[1] :=11 










KEY TYPE[1] :=0 










KEY MAP[1] :=6 


(* 


KEY 


1 = ZIPCODE 


*) 


KEY LEN[2] :=4 










KEY TYPE [2] :=0 










KEY_MAP[2] :=0 


(* 


KEY 


2 = COST NUMBER 


*) 


UNIQ KEY := 2 


(* 


USED 


IN TEST OF UNIQUENESS 


*) 



FOR KEY := TO MAX_KEY DO 
BEGIN 
IF KEY = UNIQ_KEY THEN 

KEY_DUP[KEY] := NO 
ELSE 

KEY_DUP[KEY] := YES; 

KE Y_NAME [ KE Y ] : = FLD_NAME [ KE Y_MAP [ KE Y ] ] ; 
END; 



IDX NAME[0] : 
IDX NAME[1] : 
IDX_NAME[2] : 


= 'NAME. IDX'; 
= 'ZIPC.IDX'; 
= 'NUMB. IDX'; 


NLOCK := 0; 
SLOCK := 1; 
XLOCK := 2; 
SFILE := 3; 
XFILE := 4; 
RLOCK := 5; 


(* IGNORE LOCKS 

(* SHARED RECORD LOCK 

(* EXCLUSIVE RECORD LOCK 

(* SHARED FILE LOCK 

(* EXCLUSIVE FILE LOCK 

(* RELEASE SLOCK) OR (XLOCK 



INITIALIZE INDEX FILES 



SET_LENGTH := '12345678901'; 
IDX_KEY := SET_LENGTH; 
SPACE := ' '; 
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SET TERMINAL TO -1 FOR AUTOMATIC ASSIGNMENT BY AM-80 

TERMINAL := -1; 

TRAP_ERRORS := YES; 

TIME_OUT_TEST_DELAY := 2; (* APPROXIMATELY 2 SECONDS *) 

TERMINAL := INTUS R( TERMINAL, TRAP_ERRORS , TIME_OUT_TEST_DELAY ) ; 

IP ERRCOD <> THEN 

ERROR_TYPE(0,14) ; 

NO_BUFFERS := 5; 
NO_NODE_SECTORS := 4; 
NO_DATA_FILES := 1; 
NO_KEYZ := MAXKEY + 1; 

IF SETUP(NO_BUFFERS,NO_KEYZ,NO_NODE_SECTORS,NO_DATA_FILES) <> THEN 
BEGIN 

WRITELNC Illegal SETUP Parameters'); 
EXIT; 
END; 

FOR KEY := TO MAX_KEY DO 
BEGIN 
KEY_NOM[KEY] := OPNIDX (-1, I DX_NAME [ KE Y ] , 

KEY_LEN [KEY] , KEY_TYPE [KEY] ,KEY_DUP [KEY] ) ; 
IF ERRCOD <> THEN 

ERROR_TYPE (KEY, 1) ; 
END; 



INITIALIZE DATA FILE 



FILE_NO := -1; 

RECORD_LENGTH := 100; 

F I LNAME : = ' CUSTOMER . DAT ' ; 

FILE_NO := OPNDAT (FILE_NO,SFILE ,FILNAME,RECORD_LENGTH) 

IF ERRCOD <> THEN 

ERROR_TYPE(0,10) ; 
IF LOKCOD <> THEN 

LOCK TYPE(l) ; 



CUST_REC IS THE DATA FILE BUFFER AREA 
DATBUF PTR := ADDR(DATBUF) ; 
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BEGIN DATABASE OPERATION 



NULL_BYT := 0; 
NULL_CHR := NULL_BYT; 

FOR_EVER := TRUE; 

WHILE (FOR_EVER) DO 

DATA_BASE ; 
EXIT; 



Listing 4-2. (continued) 
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